Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Simple virtual single column listbox with row header

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Simple virtual single column listbox with row header

    ' the virtual listbox can present a list array of any size.
    ' only the few currently displayed data are used by the listbox at
    ' any time.
    '
    ' you can edit any cell if you so wishes. any other operation you may want
    ' to include (e.g. sorting) should be done directly on the data array.
    ' the listbox is only used to display the data.
    '
    ' the program applies a scroll bar control and subclassing for processing of
    ' key messages.
    '
    ' the automatic "internal" movements of list boxes is being adjusted for
    ' in the program.
    '
    ' thanks to borje hagsten and lance edmonds for their inspirational influence on
    ' the present code.
    '
    ' the code skeleton was generated by ezgui freeware dialog designer
    ' by christopher r. boss see web site at ezgui.com.
    ' unused code has been removed to improve clarity.
    '
    ' your comments and suggestions for improvement are most welcome here:
    http://www.powerbasic.com/support/pb...ead.php?t=4340
    '
    ' best wishes
    '
    ' erik christensen, copenhagen, denmark ---- e.chr@email.dk
    Code:
    #compile exe
    #register none
    #dim all
    %noanimate    = 1
    %nocombo      = 1
    %nodraglist   = 1
    %noheader     = 1
    %noimagelist  = 1
    %nolistview   = 1
    %nostatusbar  = 1
    %notabcontrol = 1
    %notoolbar    = 1
    %notooltips   = 1
    %notreeview   = 1
    %noupdown     = 1
    #include "win32api.inc"
    #include "commctrl.inc"
    '
    %listbox            = 100
    %textoflistitems    = 105
    %rowheaderlist      = 110
    %exitbutton         = 115
    %rowident           = 120
    %vertscrollbar      = 135
    %editdescript       = 145
    '
    %editlabel          = 400
    %edittext           = 410
    %editok             = 415
    %editcancel         = 420
    ' --------------------------------------------------
    declare sub showlistdialog(byval hparent&)
    declare callback function listdialogproc
    declare sub editcellform(byval hparent&)
    declare callback function cbf_listbox()
    declare callback function cbf_exit()
    declare callback function cbf_edittext()
    declare callback function cbf_editok()
    declare callback function cbf_editcancel()
    declare sub updatewindowandscrollbar (byval ypos as long)
    ' --------------------------------------------------
    global brush&
    global hlistform&           ' dialog handle
    global heditform&           ' dialog handle
    
    global rows as long         ' total number of rows in array
    
    global pagerows as long     ' number of rows on a page
    
    global dataarray() as string' one dimensional text array to be displayed
    global siy as scrollinfo
    global prevkey as long      ' previously pressed key
    global goldsubclassproc&
    global prescurspos as long  ' present cursor position in grid list box
    global curscorr as long     ' correction used to place cursor correctly
    global sely as long         ' row selected
    global xcr!,ycr!            ' conversion factors from pixels to dialog units
    global xmaxscr as long
    global ymaxscr as long
    
    ' --------------------------------------------------
    '
    function pbmain
        local hdc as long
        local count&
        local cc1 as init_common_controlsex
        cc1.dwsize=sizeof(cc1)
        cc1.dwicc=%icc_win95_classes
        initcommoncontrolsex cc1
        brush&=createsolidbrush(rgb(196,196,196))  ' light grey
        showlistdialog 0
        do
            dialog doevents to count&
        loop until count&=0
        deleteobject brush&
    end function
    
    ' --------------------------------------------------
    '
    function xdu(xpct as single) as long  ' x transformation function just for this program
        xdu=xpct*430*0.01/xcr!
    end function
    '
    function ydu(ypct as single) as long  ' y transformation function just for this program
        ydu=ypct*543*0.01/1.90
    end function
    '
    sub showlistdialog(byval hparent&)
        local style&, exstyle&,hctl&,i&,j&
        local x&,y&,x1&,y1&,hdlg&,res&
    
        xmaxscr=getsystemmetrics(%sm_cxfullscreen)
        if xmaxscr >800 then xmaxscr=800
        ymaxscr=getsystemmetrics(%sm_cyfullscreen)
        if ymaxscr >543 then ymaxscr=543
        x&=300: y&=200
        dialog new 0,",,,x&,y&, %ws_visible, to hdlg&
        dialog units hdlg&, x&, y& to pixels x1&, y1&
        dialog end hdlg&
        xcr!=x1&*10000/x&: xcr!=xcr!/10000
        ycr!=y1&*10000/y&: ycr!=ycr!/10000
        '
        ' specification of size of array.
        ' you may test other size.
        rows=100000
        '
        ' the listbox routines are made for array no less than (20)
        rows=max(20,rows)
        redim dataarray(1:rows)
        ' fill array with data
        for j&=1 to rows
            dataarray(j&)=" text content of row"+str$(j&)
        next
        style& = %ws_popup or %ds_modalframe or %ws_caption or %ws_minimizebox or %ws_sysmenu or %ds_center
        exstyle& = 0
        dialog new hparent&, "virtual single column list box with row header", 0, 0,xdu(98),ydu(92), style&, exstyle& to hlistform&
        control add listbox, hlistform&,%listbox, , xdu(18.5),ydu(6.65),xdu(71.5),ydu(59.41), _
           %ws_child or %ws_visible or %lbs_notify or %ws_border or %ws_tabstop call cbf_listbox
        control add scrollbar, hlistform&,%vertscrollbar," , xdu(90),ydu(6.65),xdu(4.5),ydu(56.4), _
            %ws_child or %ws_visible or %sbs_vert
        control add listbox, hlistform&,  %rowheaderlist, ,xdu(1.5),ydu(6.65),xdu(17),ydu(59.4), _
            %ws_child or %ws_visible or %lbs_notify or %lbs_multicolumn or %ws_border or %ws_tabstop
        control add button, hlistform&,  %exitbutton,  "e&xit",xdu(80),ydu(72),xdu(10),ydu(4.43), _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_exit
        control add label, hlistform&,  %rowident," row", xdu(1.5),ydu(2.96),xdu(17),ydu(3.7), _
            %ws_child or %ws_visible
        control add label, hlistform&,  %textoflistitems," text",xdu(18.5),ydu(2.96),xdu(17),ydu(3.7), _
            %ws_child or %ws_visible
        control add label, hlistform&, %editdescript,"double-click to edit cell", xdu(33),ydu(72),xdu(35),ydu(4.43), _
            %ws_child or %ws_visible or %ss_center
        dialog show modeless hlistform& , call listdialogproc
    end sub
    ' --------------------------------------------------
    '
    callback function listdialogproc
        local hctl&,j&,result&
        select case cbmsg
            case %wm_initdialog
                control handle cbhndl, %listbox to hctl&
                goldsubclassproc = setwindowlong(hctl&, %gwl_wndproc, codeptr(subclasskeys))
                '
                ' number of rows in a displayed page
                pagerows=20
                '
                ' the scrollbar control bits are based on a fine example
                ' by lance edmonds in the source code forum.
                '
                ' define vertical scrollbar
                siy.cbsize = sizeof(siy)
                siy.fmask  = %sif_all   ' = %sif_range or %sif_page or %sif_pos
                siy.nmin   = 1
                siy.nmax   = rows
                siy.npage  = pagerows
                siy.npos   = 1
                control send cbhndl, %vertscrollbar, %sbm_setscrollinfo, %false, varptr(siy)
                '
                ' fill window with data
                for j& = siy.npos to siy.npos + siy.npage-1
                    listbox add hlistform&,%rowheaderlist,str$(j&)
                    listbox add hlistform&,%listbox,dataarray(j&)
                next
            case %wm_vscroll
                select case lowrd(cbwparam)
                    case %sb_linedown      : incr siy.npos
                    case %sb_pagedown      : siy.npos = siy.npos + siy.npage - 1
                    case %sb_lineup        : decr siy.npos
                    case %sb_pageup        : siy.npos = siy.npos - siy.npage + 1
                    case %sb_thumbtrack,%sb_thumbposition
                        ' this code allows for tracking above the 16-bit limit (65536) of hiwrd
                        ' proposed by borje hagsten
                        siy.cbsize = sizeof(siy)
                        siy.fmask  = %sif_trackpos
                        control send cbhndl, %vertscrollbar, %sbm_getscrollinfo,0, varptr(siy)
                        siy.npos   = siy.ntrackpos
                    case else              : exit function
                end select
                ' ensure that position is within range
                siy.npos = max&(siy.nmin, min&(siy.npos, siy.nmax - siy.npage + 1))
                prevkey = 0
                call updatewindowandscrollbar (siy.npos)
            case %wm_destroy
                ' important! remove the subclassing
                setwindowlong hctl&, %gwl_wndproc, goldsubclassproc
            ' -----------------------------------------------
            case %wm_ctlcolormsgbox , %wm_ctlcolorbtn, %wm_ctlcoloredit,_
                 %wm_ctlcolorstatic, %wm_ctlcolorscrollbar, %wm_ctlcolorlistbox
                ' control colors
                select case getdlgctrlid(cblparam)
                    case %rowheaderlist
                        settextcolor cbwparam, rgb(0,0,0)
                        setbkcolor   cbwparam, rgb(196,196,196)
                        function=brush&
                    case else
                        function=0
                end select
            case else
        end select
        ' enable redrawing of grid window
        control send hlistform&,%listbox,%wm_setredraw,%true,0 to result&
    end function
    ' --------------------------------------------------
    callback function subclasskeys
        ' subclass callback function for processing key messages.
        ' inspired by lance edmonds who provided a fine example in the source code forum
        local result&
        select case cbmsg
            case %wm_keydown ' keys at time of pressing
                ' the statements below for up, down, left and right move are adjusted for
                ' the "internal" automatic movement produced by the listbox.
                select case cbwparam
                    case %vk_up,%vk_left
                        if prevkey=%vk_up or prevkey=%vk_left then
                            if prescurspos <= 1 then decr siy.npos  : curscorr=1
                        elseif prevkey<>%vk_down and prevkey<>%vk_right then
                            if prescurspos  = 0 then decr siy.npos  : curscorr=1
                        end if
                    case %vk_down,%vk_right
                        if prevkey=%vk_down or prevkey=%vk_right then
                            if prescurspos >= pagerows - 2 then incr siy.npos : curscorr=-1
                        elseif prevkey<>%vk_up and prevkey<>%vk_left then
                            if prescurspos  = pagerows - 1 then incr siy.npos : curscorr=-1
                        end if
                    ' the selection movements for pgup and pgdn are the "internal" automatic listbox movements.
                    ' you may improve them.
                    case %vk_pgup  :   siy.npos = siy.npos - siy.npage + 1
                    case %vk_pgdn  :   siy.npos = siy.npos + siy.npage - 1
                    '
                    case %vk_home  :   siy.npos = 0
                    case %vk_end   :   siy.npos = rows
                    case else
                end select
                prevkey = cbwparam
                ' ensure that positions are within range
                siy.npos = max&(siy.nmin, min&(siy.npos, siy.nmax - siy.npage + 1))
                call updatewindowandscrollbar (siy.npos)
            case %wm_keyup ' keys at time of release (not used)
            case %wm_char  ' any character key at time of pressing (not used)
        end select
        ' pass the message on to the original window procedure... the ddt engine!
        function = callwindowproc(goldsubclassproc, cbhndl, cbmsg, cbwparam, cblparam)
    end function
    ' --------------------------------------------------
    sub updatewindowandscrollbar (byval ypos as long)
        ' updates the listbox data to be presented after scrolling.
        local j&,res&
        static yprevpos as long  ' previous y-position (remember between calls)
        control send hlistform&,%listbox,%lb_getcursel,0,0 to prescurspos
        if ypos<>yprevpos then ' moved
            control send hlistform&,%listbox,%wm_setredraw,%false,0 to res&
            ' update vertical scroll bar
            siy.fmask = %sif_pos
            control send hlistform&, %vertscrollbar, %sbm_setscrollinfo, %true, varptr(siy)
            control send hlistform&,%rowheaderlist,%lb_resetcontent,0,0
            control send hlistform&,%listbox,%lb_resetcontent,0,0
            for j&=ypos to ypos + pagerows - 1
                ' update row header list
                listbox add hlistform&,%rowheaderlist,str$(j&)
                ' update window data
                listbox add hlistform&,%listbox,dataarray(j&)
            next
        end if
        control send hlistform&,%listbox,%lb_setcursel,prescurspos+curscorr,0
        if prevkey = 0 then ' deselect cursor at list position zero
            control send hlistform&,%listbox,%lb_setcursel,0,0
            control send hlistform&,%listbox,%lb_setcursel,-1,0
        end if
        curscorr = 0 ' reset correction of selection position
        ' new "previous" position to be remembered for the next update call
        yprevpos=ypos
    end sub
    ' ------------------------------------------------
    callback function cbf_listbox
        if cbctlmsg=%lbn_dblclk then ' prepare for editing of selected cell
            local buffer as asciiz * 256
            local cval&
            ' return current selection in cval&
            control send cbhndl , cbctl, %lb_getcursel, 0,0 to cval&
            ' get array index corresponding to selected cell
            sely = siy.npos + cval&
            call editcellform(hlistform&) ' edit cell - new text to data array
            buffer = dataarray(sely) ' new text from data array to buffer
            ' update gridlistbox with new text
            control send cbhndl , cbctl,%lb_deletestring,cval&,0
            control send cbhndl , cbctl,%lb_insertstring,cval&,varptr(buffer)
            control send cbhndl , cbctl,%lb_setcursel, cval&,0
        end if
    end function
    ' ------------------------------------------------
    callback function cbf_exit
        local res&
        res&=msgbox ("are you sure?",%mb_yesno or %mb_iconquestion ,"exit program?")
        if res&=%idyes then dialog end hlistform&
    end function
    ' ------------------------------------------------
    sub editcellform(byval hlistform&) ' make and display edit form
        local style&, exstyle&
        style& = %ws_popup or %ds_modalframe or %ws_caption or %ds_center
        exstyle& = 0
        dialog new hlistform&, "edit cell", 0, 0,  200,  48, style&, exstyle& to heditform&
        control add label, heditform&,  %editlabel,"  row"+str$(sely), 6, 2, 188, 10, _
            %ws_child or %ws_visible or %ss_center
        control add textbox, heditform&,  %edittext,  dataarray(sely), 6, 12, 188, 12, _
            %ws_child or %ws_visible or %es_autohscroll or %ws_tabstop, _
            %ws_ex_clientedge
        control add button, heditform&,  %editok,  "&ok", 154, 30, 40, 12, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_editok
        control add button, heditform&,  %editcancel,  "&cancel", 104, 30, 40, 12, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_editcancel
        dialog show modal heditform&
    end sub
    ' ------------------------------------------------
    callback function cbf_editok
        local txt$
        control get text heditform&,%edittext to txt$
        ' update data array with edited text
        dataarray(sely)=txt$
        dialog end heditform&
    end function
    ' ------------------------------------------------
    callback function cbf_editcancel
        dialog end heditform&
    end function

    ------------------




    [this message has been edited by erik christensen (edited october 06, 2001).]

  • #2
    ' In this slightly improved version you can also activate editing of the
    ' current cell by pressing ENTER. You can still double click the cell for
    ' the same purpose. Furthermore, you can also use ENTER and ESC to
    ' terminate editing of a cell in addition to using the buttons.
    '
    ' Semen Matusovski, Borje Hagsten, Adrian Aitken and Lance Edmonds are
    ' thanked for their inspirational influence on the code.
    '
    ' Erik Christensen, Copenhagen, Denmark ---- e.chr@email.dk
    Code:
    #COMPILE EXE
    #REGISTER NONE
    #DIM ALL
    %NOANIMATE    = 1
    %NOCOMBO      = 1
    %NODRAGLIST   = 1
    %NOHEADER     = 1
    %NOIMAGELIST  = 1
    %NOLISTVIEW   = 1
    %NOSTATUSBAR  = 1
    %NOTABCONTROL = 1
    %NOTOOLBAR    = 1
    %NOTOOLTIPS   = 1
    %NOTREEVIEW   = 1
    %NOUPDOWN     = 1
    #INCLUDE "win32api.inc"
    #INCLUDE "commctrl.inc"
    '
    %ListBox            = 100
    %TextOfListItems    = 105
    %RowHeaderList      = 110
    %ExitButton         = 115
    %RowIdent           = 120
    %VertScrollbar      = 135
    %EditDescript       = 145
    '
    %EditLabel          = 400
    %EditText           = 410
    %EditOK             = 415
    %EditCancel         = 420
    ' --------------------------------------------------
    DECLARE SUB ShowListDialog(BYVAL hParent&)
    DECLARE CALLBACK FUNCTION ListDialogProc
    DECLARE CALLBACK FUNCTION EditDialogProc
    DECLARE SUB EditCellForm(BYVAL hParent&)
    DECLARE CALLBACK FUNCTION CBF_ListBox()
    DECLARE CALLBACK FUNCTION CBF_HeaderBox()
    DECLARE CALLBACK FUNCTION CBF_Exit()
    DECLARE CALLBACK FUNCTION CBF_EditText()
    DECLARE CALLBACK FUNCTION CBF_EditOK()
    DECLARE CALLBACK FUNCTION CBF_EditCancel()
    DECLARE SUB UpdateWindowAndScrollbar (BYVAL yPos AS LONG)
    ' --------------------------------------------------
    GLOBAL Brush&
    GLOBAL hListForm&           ' Dialog handle
    GLOBAL hEditForm&           ' Dialog handle
    
    GLOBAL Rows AS LONG         ' Total number of rows in array
    
    GLOBAL PageRows AS LONG     ' Number of rows on a page
    
    GLOBAL DataArray() AS STRING' One dimensional text array to be displayed
    GLOBAL siY AS SCROLLINFO
    GLOBAL PrevKey AS LONG      ' Previously pressed key
    GLOBAL gOldSubClassList&
    GLOBAL gOldSubClassEdit&
    GLOBAL PresCursPos AS LONG  ' Present cursor position in grid list box
    GLOBAL CursCorr AS LONG     ' Correction used to place cursor correctly
    GLOBAL SelY AS LONG         ' Row selected
    GLOBAL XCR!,YCR!            ' conversion factors from pixels to dialog units
    GLOBAL XMaxScr AS LONG
    GLOBAL YMaxScr AS LONG
    ' --------------------------------------------------
    '
    FUNCTION PBMAIN
        LOCAL hDC AS LONG
        LOCAL Count&
        LOCAL CC1 AS INIT_COMMON_CONTROLSEX
        CC1.dwSize=SIZEOF(CC1)
        CC1.dwICC=%ICC_WIN95_CLASSES
        InitCommonControlsEX CC1
        Brush&=CreateSolidBrush(RGB(196,196,196))  ' light grey
        ShowListDialog 0
        DO
            DIALOG DOEVENTS TO Count&
        LOOP UNTIL Count&=0
        DeleteObject Brush&
    END FUNCTION
    ' --------------------------------------------------
    '
    FUNCTION XDU(XPct AS SINGLE) AS LONG  ' X transformation function just for this program
        XDU=XPct*430*0.01/XCR!
    END FUNCTION
    '
    FUNCTION YDU(YPct AS SINGLE) AS LONG  ' Y transformation function just for this program
        YDU=YPct*543*0.01/1.90
    END FUNCTION
    '
    SUB ShowListDialog(BYVAL hParent&)
        LOCAL Style&, ExStyle&,hCtl&,i&,j&
        LOCAL X&,Y&,X1&,Y1&,hDlg&,res&
    
        XMaxScr=GetSystemMetrics(%SM_CXFULLSCREEN)
        IF XMaxScr >800 THEN XMaxScr=800
        YMaxScr=GetSystemMetrics(%SM_CYFULLSCREEN)
        IF YMaxScr >543 THEN YMaxScr=543
        X&=300: Y&=200
        DIALOG NEW 0,"",,,X&,Y&, %WS_VISIBLE, TO hDlg&
        DIALOG UNITS hDlg&, X&, Y& TO PIXELS X1&, Y1&
        DIALOG END hDlg&
        XCR!=X1&*10000/X&: XCR!=XCR!/10000
        YCR!=Y1&*10000/Y&: YCR!=YCR!/10000
        '
        ' Specification of size of array.
        ' You may test other size.
        Rows=100000
        '
        ' The listbox routines are made for array no less than (20)
        Rows=MAX(20,Rows)
        REDIM DataArray(1:Rows)
        ' Fill array with data
        FOR j&=1 TO Rows
            DataArray(j&)=" text content of row"+STR$(j&)
        NEXT
        Style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %WS_MINIMIZEBOX OR %WS_SYSMENU OR %DS_CENTER
        ExStyle& = 0
        DIALOG NEW hParent&, "Virtual Single Column List Box", 0, 0,XDU(98),YDU(92), Style&, ExStyle& TO hListForm&
        CONTROL ADD LISTBOX, hListForm&,%ListBox, , XDU(18.5),YDU(6.65),XDU(71.5),YDU(59.41), _
           %WS_CHILD OR %WS_VISIBLE OR %LBS_NOTIFY OR %WS_BORDER OR %WS_TABSTOP CALL CBF_ListBox
        CONTROL ADD SCROLLBAR, hListForm&,%VertScrollbar,"" , XDU(90.1),YDU(6.65),XDU(4.5),YDU(56.4), _
            %WS_CHILD OR %WS_VISIBLE OR %SBS_VERT
        CONTROL ADD LISTBOX, hListForm&,  %RowHeaderList, ,XDU(1.5),YDU(6.65),XDU(17),YDU(59.4), _
            %WS_CHILD OR %WS_VISIBLE OR %LBS_NOTIFY OR %WS_BORDER OR %WS_TABSTOP CALL CBF_HeaderBox
        CONTROL ADD BUTTON, hListForm&,  %ExitButton,  "E&xit",XDU(80),YDU(72),XDU(10),YDU(4.43), _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_Exit
        CONTROL ADD LABEL, hListForm&,  %RowIdent," Row", XDU(1.5),YDU(2.96),XDU(17),YDU(3.7), _
            %WS_CHILD OR %WS_VISIBLE
        CONTROL ADD LABEL, hListForm&,  %TextOfListItems," Text",XDU(18.5),YDU(2.96),XDU(17),YDU(3.7), _
            %WS_CHILD OR %WS_VISIBLE
        CONTROL ADD LABEL, hListForm&, %EditDescript,"Press ENTER or Double-click to edit cell", XDU(12),YDU(72),XDU(63),YDU(4.43), _
            %WS_CHILD OR %WS_VISIBLE OR %SS_CENTER
        DIALOG SHOW MODELESS hListForm& , CALL ListDialogProc
    END SUB
    ' --------------------------------------------------
    '
    CALLBACK FUNCTION ListDialogProc
        LOCAL hCtl&,j&,Result&
        SELECT CASE CBMSG
            CASE %WM_INITDIALOG
                CONTROL HANDLE CBHNDL, %ListBox TO hCtl&
                gOldSubClassList = SetWindowLong(hCtl&, %GWL_WNDPROC, CODEPTR(SubClassListKeys))
                '
                ' Number of rows in a displayed page
                PageRows=20
                '
                ' The scrollbar control bits are based on a fine example
                ' by Lance Edmonds in the source code forum.
                '
                ' Define vertical scrollbar
                siY.cbSize = SIZEOF(siY)
                siY.fMask  = %SIF_ALL   ' = %SIF_RANGE OR %SIF_PAGE OR %SIF_POS
                siY.nMin   = 1
                siY.nMax   = Rows
                siY.nPage  = PageRows
                siY.nPos   = 1
                CONTROL SEND CBHNDL, %VertScrollbar, %SBM_SETSCROLLINFO, %FALSE, VARPTR(siY)
                '
                ' Fill window with data
                CALL UpdateWindowAndScrollbar (siY.nPos)
            CASE %WM_VSCROLL
                SELECT CASE LOWRD(CBWPARAM)
                    CASE %SB_LINEDOWN      : INCR siY.nPos
                    CASE %SB_PAGEDOWN      : siY.nPos = siY.nPos + siY.nPage - 1
                    CASE %SB_LINEUP        : DECR siY.nPos
                    CASE %SB_PAGEUP        : siY.nPos = siY.nPos - siY.nPage + 1
                    CASE %SB_THUMBTRACK,%SB_THUMBPOSITION
                        ' This code allows for tracking above the 16-bit limit (65536) of HIWRD
                        ' Proposed by Borje Hagsten
                        siY.cbSize = SIZEOF(siY)
                        siY.fMask  = %SIF_TRACKPOS
                        CONTROL SEND CBHNDL, %VertScrollbar, %SBM_GETSCROLLINFO,0, VARPTR(siY)
                        siY.nPos   = siY.nTrackPos
                    CASE ELSE              : EXIT FUNCTION
                END SELECT
                ' Ensure that position is within range
                siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
                ' Reset previous key flag
                PrevKey = 0
                CALL UpdateWindowAndScrollbar (siY.nPos)
            CASE %WM_DESTROY
                ' Important! Remove the subclassing
                SetWindowLong hCtl&, %GWL_WNDPROC, gOldSubClassList
            ' -----------------------------------------------
            CASE %WM_CTLCOLORMSGBOX , %WM_CTLCOLORBTN, %WM_CTLCOLOREDIT,_
                 %WM_CTLCOLORSTATIC, %WM_CTLCOLORSCROLLBAR, %WM_CTLCOLORLISTBOX
                ' Control colors
                SELECT CASE GetDlgCtrlID(CBLPARAM)
                    CASE %RowHeaderList
                        SetTextColor CBWPARAM, RGB(0,0,0)
                        SetBkColor   CBWPARAM, RGB(196,196,196)
                        FUNCTION=Brush&
                    CASE ELSE
                        FUNCTION=0
                END SELECT
            CASE ELSE
        END SELECT
        ' Enable redrawing of listbox
        CONTROL SEND hListForm&,%ListBox,%WM_SETREDRAW,%TRUE,0 TO Result&
    
    END FUNCTION
    ' --------------------------------------------------
    CALLBACK FUNCTION SubClassListKeys
        ' Subclass callback function for processing key messages.
        ' Inspired by Lance Edmonds who provided a fine example in the Source Code Forum
        ' Completed after valuable feedback by Semen Matusovski and Borje Hagsten.
        LOCAL Result&
        '
        SELECT CASE CBMSG
            ' The %WM_GETDLGCODE message is sent to the dialog box procedure
            ' associated with a control. Normally, Windows handles all arrow-key
            ' and TAB-key input to the control.
            ' By responding to the %WM_GETDLGCODE message, an application can
            ' take control of a particular type of input and process the input itself.
            CASE %WM_GETDLGCODE
                ' Specifies that the only extra key we want to be available is
                ' the ENTER key (= %VK_RETURN) (chr$(13)).
                ' This particular expression was proposed by Borje Hagsten
                IF CBWPARAM = %VK_RETURN THEN
                    FUNCTION = %DLGC_WANTALLKEYS : EXIT FUNCTION
                END IF
            CASE %WM_KEYDOWN ' Keys at time of pressing
                ' The statements below for UP, DOWN, LEFT and RIGHT move are adjusted for
                ' the "internal" automatic movement produced by the listbox.
                SELECT CASE CBWPARAM
                    CASE %VK_UP,%VK_LEFT
                        IF PrevKey=%VK_UP OR PrevKey=%VK_LEFT THEN
                            IF PresCursPos <= 1 THEN DECR siY.nPos  : CursCorr=1
                        ELSEIF PrevKey<>%VK_DOWN AND PrevKey<>%VK_RIGHT THEN
                            IF PresCursPos  = 0 THEN DECR siY.nPos  : CursCorr=1
                        END IF
                    CASE %VK_DOWN,%VK_RIGHT
                        IF PrevKey=%VK_DOWN OR PrevKey=%VK_RIGHT THEN
                            IF PresCursPos >= PageRows - 2 THEN INCR siY.nPos : CursCorr=-1
                        ELSEIF PrevKey<>%VK_UP AND PrevKey<>%VK_LEFT THEN
                            IF PresCursPos  = PageRows - 1 THEN INCR siY.nPos : CursCorr=-1
                        END IF
                    ' The selection movements for PGUP and PGDN are the "internal" automatic listbox movements.
                    ' You may improve them.
                    CASE %VK_PGUP  :   siY.nPos = siY.nPos - siY.nPage + 1
                    CASE %VK_PGDN  :   siY.nPos = siY.nPos + siY.nPage - 1
                    '
                    CASE %VK_HOME  :   siY.nPos = 0
                    CASE %VK_END   :   siY.nPos = Rows
                    CASE ELSE
                END SELECT
                PrevKey = CBWPARAM
                ' Ensure that positions are within range
                siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
                CALL UpdateWindowAndScrollbar (siY.nPos)
            CASE %WM_KEYUP ' Keys at time of release (not used)
            CASE %WM_CHAR  ' Any character key at time of pressing
                SELECT CASE CBWPARAM ' Holds the code of the key.
                    ' Specify what action should be taken for each key code.
                    CASE 13 ' ENTER pressed
                        ' Ensure that a cell is selected before editing.
                        ' Otherwise you will have a fatal error !
                        CONTROL SEND hListForm&,%ListBox,%LB_GETCARETINDEX,0,0 TO Result&
                        CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL, Result&,-1
                        CALL PrepareForEdit
                        EXIT FUNCTION
                    CASE ELSE ' No action to be taken here for the other keys.
                END SELECT
        END SELECT
        ' Pass the message on to the original window procedure... the DDT engine!
        FUNCTION = CallWindowProc(gOldSubClassList, CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
    END FUNCTION
    ' --------------------------------------------------
    SUB UpdateWindowAndScrollbar (BYVAL yPos AS LONG)
        ' Updates the listbox data to be presented after scrolling.
        LOCAL j&,Res&
        STATIC yPrevPos AS LONG  ' previous y-position (remember between calls)
        CONTROL SEND hListForm&,%ListBox,%LB_GETCURSEL,0,0 TO PresCursPos
        IF yPos<>yPrevPos THEN ' Moved
            CONTROL SEND hListForm&,%ListBox,%WM_SETREDRAW,%FALSE,0 TO Res&
            ' Update vertical scroll bar
            siY.fMask = %SIF_POS
            CONTROL SEND hListForm&, %VertScrollbar, %SBM_SETSCROLLINFO, %TRUE, VARPTR(siY)
            CONTROL SEND hListForm&,%RowHeaderList,%LB_RESETCONTENT,0,0
            CONTROL SEND hListForm&,%ListBox,%LB_RESETCONTENT,0,0
            FOR j&=yPos TO yPos + PageRows - 1
                ' Update row header list
                LISTBOX ADD hListForm&,%RowHeaderList,STR$(j&)
                ' Update window data
                LISTBOX ADD hListForm&,%ListBox,DataArray(j&)
            NEXT
        END IF
        CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL,PresCursPos+CursCorr,0
        IF PrevKey = 0 THEN ' Deselect cursor at list position zero
            CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL,0,0
            CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL,-1,0
        END IF
        CursCorr = 0 ' Reset correction of selection position
        ' New "previous" position to be remembered for the next update call
        yPrevPos=yPos
    END SUB
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_ListBox
        IF CBCTLMSG=%LBN_DBLCLK THEN CALL PrepareForEdit
    END FUNCTION
    ' ------------------------------------------------
    SUB PrepareForEdit
        LOCAL buffer AS ASCIIZ * 256
        LOCAL CVal&
        ' Return Current Selection in CVal&
        CONTROL SEND hListForm&,%ListBox, %LB_GETCURSEL, 0,0 TO CVal&
        ' Get array index corresponding to selected cell
        SelY = siY.nPos + CVal&
        CALL EditCellForm(hListForm&) ' Edit cell - new text to data array
        buffer = DataArray(SelY) ' new text from data array to buffer
        ' Update ListBox with new text
        CONTROL SEND hListForm&,%ListBox,%LB_DELETESTRING,CVal&,0
        CONTROL SEND hListForm&,%ListBox,%LB_INSERTSTRING,CVal&,VARPTR(buffer)
        CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL, CVal&,-1
    END SUB
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_HeaderBox
        ' set focus to %ListBox
        CONTROL SET FOCUS hListForm&, %ListBox
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_Exit
        LOCAL res&
        res&=MSGBOX ("Are you sure?",%MB_YESNO OR %MB_ICONQUESTION ,"Exit Program?")
        IF res&=%IDYES THEN DIALOG END hListForm&
    END FUNCTION
    '
    ' ------------------------------------------------
    ' Code section for editing of cell text
    ' ------------------------------------------------
    '
    SUB EditCellForm(BYVAL hListForm&) ' make and display edit form
        LOCAL Style&, ExStyle&
        Style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %DS_CENTER
        ExStyle& = 0
        DIALOG NEW hListForm&, "Edit cell", 0, 0,  200,  48, Style&, ExStyle& TO hEditForm&
        CONTROL ADD LABEL, hEditForm&,  %EditLabel,"  Row"+STR$(SelY), 6, 2, 188, 10, _
            %WS_CHILD OR %WS_VISIBLE OR %SS_CENTER
        CONTROL ADD TEXTBOX, hEditForm&,  %EditText,  DataArray(SelY), 6, 12, 188, 12, _
            %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP,%WS_EX_CLIENTEDGE
        ' The following two statements deselect the text and place caret at the end of the text.
        CONTROL SEND hEditForm&, %EditText,%EM_SETSEL,0,-1  ' select all text
        CONTROL SEND hEditForm&, %EditText,%EM_SETSEL,-1,-1 ' deselect text
        CONTROL ADD BUTTON, hEditForm&,  %EditOK,  "&OK", 154, 30, 40, 12, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_EditOK
        CONTROL ADD BUTTON, hEditForm&,  %EditCancel,  "&Cancel", 104, 30, 40, 12, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_EditCancel
        DIALOG SHOW MODAL hEditForm&, CALL EditDialogProc
    END SUB
    ' ------------------------------------------------
    CALLBACK FUNCTION EditDialogProc
        LOCAL hCtl&,j&,Result&
        SELECT CASE CBMSG
            CASE %WM_INITDIALOG
                CONTROL HANDLE CBHNDL, %EditText TO hCtl&
                gOldSubClassEdit& = SetWindowLong(hCtl&, %GWL_WNDPROC, CODEPTR(SubClassEditKeys))
            CASE %WM_DESTROY
                ' Important! Remove the subclassing
                SetWindowLong hCtl&, %GWL_WNDPROC, gOldSubClassEdit&
            CASE ELSE
        END SELECT
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION SubClassEditKeys
        ' Subclass callback function for processing key messages in edit control (textbox).
        ' Completed after valuable feedback by Semen Matusovski and Borje Hagsten.
        LOCAL Result&
        '
        SELECT CASE CBMSG
            '
            ' The %WM_GETDLGCODE message is sent to the dialog box procedure
            ' associated with a control. Normally, Windows handles all arrow-key
            ' and TAB-key input to the control.
            ' By responding to the %WM_GETDLGCODE message, an application can
            ' take control of a particular type of input and process the input itself.
            CASE %WM_GETDLGCODE
                ' Specifies that we want all keys entered in the textbox to be
                ' available here.
                FUNCTION = %DLGC_WANTALLKEYS: EXIT FUNCTION
            CASE %WM_KEYDOWN ' Keys at time of pressing (not used here)
            CASE %WM_KEYUP   ' Keys at time of release (not used here)
            CASE %WM_CHAR    ' Any character key at time of pressing
                SELECT CASE CBWPARAM ' Holds the code of the key.
                    ' Specify what action should be taken for each key code.
                    CASE 13 ' ENTER pressed
                        CONTROL GET TEXT hEditForm&,%EditText TO DataArray(SelY)
                        CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL,-1,0 ' deselect cell
                        DIALOG END hEditForm&
                        EXIT FUNCTION
                    CASE 27 ' ESCAPE pressed
                        DIALOG END hEditForm&
                        EXIT FUNCTION
                    CASE ELSE ' No action to be taken here for the other keys.
                END SELECT
        END SELECT
        ' Pass the message on to the original window procedure... the DDT engine!
        FUNCTION = CallWindowProc(gOldSubClassEdit&, CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_EditOK
        ' update data array with edited text
        CONTROL GET TEXT hEditForm&,%EditText TO DataArray(SelY)
        DIALOG END hEditForm&
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_EditCancel
        DIALOG END hEditForm&
    END FUNCTION

    ------------------




    [This message has been edited by Erik Christensen (edited October 16, 2001).]

    Comment

    Working...
    X