Tweet
' this program presents a virtual multicolumn listbox to simulate
' a listview like "grid control". the virtual multicolumn listbox can
' present two dimensional string arrays of any size. only the part of the
' data being displayed at any one time are being used by the listbox.
'
' the program applies scroll bar controls and subclassing for processing of
' key messages.
'
' 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.
' due to the automatic "internal" movements of list boxes, the code for movement
' by using the arrow keys is quite complex and possibly rather obscure. it
' could no doubt be improved in certain aspects.
'
' 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.
'
' p.s. october, 16th 2001:
' the program has been improved thanks to received feedback. now 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.
'
' best wishes
'
' erik christensen, copenhagen, denmark ---- [email protected]
' further comments should go to this address:
http://www.powerbasic.com/support/pb...ead.php?t=4340
[this message has been edited by erik christensen (edited october 16, 2001).]
' a listview like "grid control". the virtual multicolumn listbox can
' present two dimensional string arrays of any size. only the part of the
' data being displayed at any one time are being used by the listbox.
'
' the program applies scroll bar controls and subclassing for processing of
' key messages.
'
' 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.
' due to the automatic "internal" movements of list boxes, the code for movement
' by using the arrow keys is quite complex and possibly rather obscure. it
' could no doubt be improved in certain aspects.
'
' 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.
'
' p.s. october, 16th 2001:
' the program has been improved thanks to received feedback. now 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.
'
' best wishes
'
' erik christensen, copenhagen, denmark ---- [email protected]
' further comments should go to this address:
http://www.powerbasic.com/support/pb...ead.php?t=4340
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"
'
%gridlistbox = 100
%colheaderlist = 105
%rowheaderlist = 110
%exitbutton = 115
%rowident = 120
%vertscrollbar = 135
%horzscrollbar = 140
%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_gridlistbox()
declare callback function cbf_colheaderbox()
declare callback function cbf_rowheaderbox()
declare callback function cbf_rowident()
declare callback function cbf_exit()
declare callback function cbf_edittext()
declare callback function cbf_editok()
declare callback function cbf_editcancel()
declare sub updatewindowandscrollbars (byval xpos as long,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 columns as long ' total number of columns in array
global pagerows as long ' number of rows on a page
global pagecolumns as long ' number of columns on a page
global dataarray() as string' two dimensional text array to be displayed
global colhead() as string ' column header array
global rowhead() as string ' row header array
global six as scrollinfo
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 selx as long ' column selected
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*800*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 sizes.
rows=100
columns=500
'
' grid routines are made for arrays no less than (4,20)
columns=max(4,columns)
rows=max(20,rows)
' fill array with data
redim dataarray(1:columns,1:rows)
redim colhead(1:columns)
redim rowhead(1:rows)
for i&=1 to columns
colhead(i&)=" column"+str$(i&)
for j&=1 to rows
if i&=1 then rowhead(j&)=" row"+str$(j&)
dataarray(i&,j&)=" column"+str$(i&)+" row"+str$(j&)
next
next
style& = %ws_popup or %ds_modalframe or %ws_caption or %ws_minimizebox or %ws_sysmenu or %ds_center
exstyle& = 0
dialog new hparent&, "multicolumn list box for grid data", 0, 0,xdu(98),ydu(92), style&, exstyle& to hlistform&
control add listbox, hlistform&,%gridlistbox, , xdu(18.5),ydu(6.65),xdu(71.5),ydu(59.41), _
%ws_child or %ws_visible or %lbs_notify or %lbs_multicolumn or %ws_border or %ws_tabstop call cbf_gridlistbox
control send hlistform&,%gridlistbox,%lb_setcolumnwidth,xdu(17.8)*xcr!,0
control add scrollbar, hlistform&,%horzscrollbar," ,xdu(18.5),ydu(63),xdu(71.5),ydu(3.7), _
%ws_child or %ws_visible or %sbs_horz
control add scrollbar, hlistform&,%vertscrollbar," , xdu(90),ydu(6.65),xdu(2.5),ydu(56.4), _
%ws_child or %ws_visible or %sbs_vert
control add listbox, hlistform&, %colheaderlist, ,xdu(18.5),ydu(2.96),xdu(71.5),ydu(3.7), _
%ws_child or %ws_visible or %lbs_notify or %lbs_multicolumn or %lbs_nointegralheight or %ws_border or %ws_tabstop call cbf_colheaderbox
control send hlistform&,%colheaderlist,%lb_setcolumnwidth,xdu(17.8)*xcr!,0
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 call cbf_rowheaderbox
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 listbox, hlistform&, %rowident, , xdu(1.5),ydu(2.96),xdu(17),ydu(3.7), _
%ws_child or %ws_visible or %lbs_notify or %lbs_nointegralheight or %ws_border or %ws_tabstop call cbf_rowident
listbox add hlistform&,%rowident,"row identification"
control add label, hlistform&, %editdescript,"press enter or double-click to edit cell", xdu(32),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&, result&,i&,j&,n&
local cursel&
select case cbmsg
case %wm_initdialog
control handle cbhndl, %gridlistbox to hctl&
goldsubclasslist& = setwindowlong(hctl&, %gwl_wndproc, codeptr(subclasslistkeys))
'
' number of rows and columns in a displayed page
pagerows=20
pagecolumns = 4
'
' 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)
'
' define horizontal scrollbar
six.cbsize = sizeof(six)
six.fmask = %sif_all ' = %sif_range or %sif_page or %sif_pos
six.nmin = 1
six.nmax = columns
six.npage = pagecolumns
six.npos = 1
control send cbhndl,%horzscrollbar, %sbm_setscrollinfo, %false, varptr(six)
'
' fill window with data
call updatewindowandscrollbars (six.npos,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))
prevkey = 0
call updatewindowandscrollbars (six.npos,siy.npos)
case %wm_hscroll
select case lowrd(cbwparam)
case %sb_lineright : incr six.npos
case %sb_pageright : six.npos = six.npos + six.npage - 1
case %sb_lineleft : decr six.npos
case %sb_pageleft : six.npos = six.npos - six.npage + 1
case %sb_thumbtrack,%sb_thumbposition
' this code allows for tracking above the 16-bit limit (65536) of hiwrd
' proposed by borje hagsten
six.cbsize = sizeof(six)
six.fmask = %sif_trackpos
control send cbhndl, %horzscrollbar, %sbm_getscrollinfo,0, varptr(six)
six.npos = six.ntrackpos
case else : exit function
end select
' ensure that position is within range
six.npos = max&(six.nmin, min&(six.npos, six.nmax - six.npage + 1))
prevkey = 0
call updatewindowandscrollbars (six.npos,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 %colheaderlist
settextcolor cbwparam, rgb(0,0,0) ' black
setbkcolor cbwparam, rgb(196,196,196) ' light grey
function=brush&
case %rowheaderlist
settextcolor cbwparam, rgb(0,0,0)
setbkcolor cbwparam, rgb(196,196,196)
function=brush&
case %rowident
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&,%gridlistbox,%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
if prevkey=%vk_up then
if prescurspos mod pagerows <= 1 then decr siy.npos : curscorr=1
elseif prevkey<>%vk_down then
if prescurspos mod pagerows = 0 then decr siy.npos : curscorr=1
end if
case %vk_down
if prevkey=%vk_down then
if prescurspos mod pagerows >= pagerows - 2 then incr siy.npos : curscorr=-1
elseif prevkey<>%vk_up then
if prescurspos mod pagerows = pagerows - 1 then incr siy.npos : curscorr=-1
end if
case %vk_left
if prevkey=%vk_left then
if prescurspos <pagerows*2 then decr six.npos
elseif prevkey<>%vk_right then
if prescurspos <pagerows*1 then decr six.npos
end if
case %vk_right
if prevkey=%vk_right then
if prescurspos >=pagerows*(pagecolumns-2) then incr six.npos : curscorr=-pagerows
elseif prevkey<>%vk_left then
if prescurspos >=pagerows*(pagecolumns-1) then incr six.npos : curscorr=-pagerows
end if
' the selection movements for pgup and pgdn are the "internal" automatic listbox movements.
' i have not been able to adjust them satisfactorily. you may have an idea.
case %vk_pgup : siy.npos = siy.npos - siy.npage + 1
case %vk_pgdn : siy.npos = siy.npos + siy.npage - 1
'
case %vk_home : six.npos = 0: siy.npos = 0
case %vk_end : six.npos = columns: siy.npos = rows
case else
end select
prevkey = cbwparam
' ensure that positions are within range
six.npos = max&(six.nmin, min&(six.npos, six.nmax - six.npage + 1))
siy.npos = max&(siy.nmin, min&(siy.npos, siy.nmax - siy.npage + 1))
call updatewindowandscrollbars (six.npos,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&,%gridlistbox,%lb_getcaretindex,0,0 to result&
control send hlistform&,%gridlistbox,%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 updatewindowandscrollbars (byval xpos as long,byval ypos as long)
' updates the listbox data to be presented after scrolling.
local i&,j&,res&
static yprevpos as long ' previous y-position (remember between calls)
static xprevpos as long ' previous x-position (remember between calls)
control send hlistform&,%gridlistbox,%lb_getcursel,0,0 to prescurspos
if xpos<>xprevpos or ypos<>yprevpos then ' moved
control send hlistform&,%gridlistbox,%wm_setredraw,%false,0 to res&
if xpos<>xprevpos then ' moved in x-direction (horizontal)
' update horizontal scroll bar
six.fmask = %sif_pos
control send hlistform&, %horzscrollbar, %sbm_setscrollinfo, %true, varptr(six)
' update column header
control send hlistform&,%colheaderlist,%lb_resetcontent,0,0
for i&=xpos to xpos + pagecolumns - 1
listbox add hlistform&,%colheaderlist,colhead(i&)
next
end if
if ypos<>yprevpos then ' moved in y-direction (vertical)
' update vertical scroll bar
siy.fmask = %sif_pos
control send hlistform&, %vertscrollbar, %sbm_setscrollinfo, %true, varptr(siy)
' update row header
control send hlistform&,%rowheaderlist,%lb_resetcontent,0,0
for j&=ypos to ypos + pagerows - 1
listbox add hlistform&,%rowheaderlist,rowhead(j&)
next
end if
' update window data
control send hlistform&,%gridlistbox,%lb_resetcontent,0,0
for i&=xpos to xpos + pagecolumns - 1
for j&=ypos to ypos + pagerows - 1
listbox add hlistform&,%gridlistbox,dataarray(i&,j&)
next
next
end if
control send hlistform&,%gridlistbox,%lb_setcursel,prescurspos+curscorr,0
if prevkey = 0 then ' deselect cursor at list position zero
control send hlistform&,%gridlistbox,%lb_setcursel,0,0
control send hlistform&,%gridlistbox,%lb_setcursel,-1,0
end if
curscorr = 0 ' reset correction of selection position
' new "previous" positions to be remembered for the next update call
yprevpos=ypos: xprevpos=xpos
end sub
' ------------------------------------------------
callback function cbf_gridlistbox
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&,%gridlistbox, %lb_getcursel, 0,0 to cval&
' get array index corresponding to selected cell
selx = six.npos+int(cval&/pagerows)
sely = siy.npos+cval& mod pagerows
call editcellform(hlistform&) ' edit cell - new text to data array
buffer = dataarray(selx,sely) ' new text from data array to buffer
' update listbox with new text
control send hlistform&,%gridlistbox,%lb_deletestring,cval&,0
control send hlistform&,%gridlistbox,%lb_insertstring,cval&,varptr(buffer)
control send hlistform&,%gridlistbox,%lb_setcursel, cval&,-1
end sub
' ------------------------------------------------
callback function cbf_rowheaderbox
control set focus hlistform&, %gridlistbox
end function
' ------------------------------------------------
callback function cbf_colheaderbox
control set focus hlistform&, %gridlistbox
end function
' ------------------------------------------------
callback function cbf_rowident
control set focus hlistform&, %gridlistbox
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, "column"+str$(selx)+" row"+str$(sely), 6, 2, 188, 10, _
%ws_child or %ws_visible or %ss_center
control add textbox, heditform&, %edittext, dataarray(selx,sely), 6, 12, 188, 12, _
%ws_child or %ws_visible or %es_autohscroll 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(selx,sely)
control send hlistform&,%gridlistbox,%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(selx,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