Tweet
' custom drawn virtual listview grid control with full
' selection capability - for pbwin 6.x and 7.x.
'
' improved version july 12, 2003
'
' according to your need this skeleton code may be expanded
' with editing, sorting and mouse dragging facilities. the
' latter will probably need a mouse hook. the custom drawing
' allows each cell to have its own background and foreground
' color as well as its own font.
'
' at present there is only a modest utilization of such
' features. i leave further developments to you. you may see
' these links for previous colorful versions:
http://www.powerbasic.com/support/pb...ad.php?t=23229
http://www.powerbasic.com/support/pb...ad.php?t=24782
' the present version suppresses listview's built-in selection
' capability, which is limited either to the first column or
' to full rows. the suppression is done by omitting the
' %lvs_ex_fullrowselect style and maintaining a zero width
' of the first column. this makes it possible to devise
' selection of any group of cells to be copied to the
' clipboard and from there to other programs like word and
' excel. you can also copy the other way - e.g. from excel
' to the grid - via the clipboard. extended selection is
' invoked using f8 or via a shortcut menu obtained using
' the right mouse button. this menu is also used to select
' full rows and columns and for copying and pasting. the
' original format (font, alignment, color etc.) of the target
' cells is maintained after receiving the new data from the
' clipboard. only the content is changed.
' external scroll bars are replacing those of listview, which
' is defined using the %lvs_noscroll style. therefore
' listview needs only handle data being displayed at any
' one time plus a few extra columns as reserve. thus there
' is no limit to the number of rows and columns, which may
' be handled, other than the amount of available computer
' memory.
' since the virtual listview functions are not designed
' to work with the no-scroll style, the scroll messages
' need to be handled in a separate callback function to
' ensure smooth scrolling.
' in the present version alternate lines are given slightly
' different background colors. if you want grid-lines,
' these can easily be added by uncommenting this statement:
' "' i = i or %lvs_ex_gridlines" in callback function
' listviewwindowcallback.
' thanks to peter stephensen for the clipboard routines
' and to semen matusovski, david kenny, lance edmonds,
' borje hagsten and david l. morris for help in earlier
' virtual listview developmental phases.
' best of luck.
' erik christensen ------ [email protected] ------- june 21, 2003
'
' july 12, 2003: some improvements have been made: the line
' height has been increased using a technique provided by
' edwin knoppert. an undo last paste has been added and the
' key scrolling performance has been improved somewhat to
' approach that of excel. the program structure has also been
' changed slightly and the font has been changed to arial.
[CODE]
#compile exe
#register none
#dim all
'
' in this program only listview and header controls use the commctrl.inc file
%noanimate = 1 ' animate control.
%nobutton = 1
%nocombo = 1
%nodatetimepick = 1
%nodraglist = 1 ' apis to make a listbox source and sink drag&drop actions.
%noedit = 1
%noflatsbapis = 1
' %noheader = 1 ' header bar control.
%nohotkey = 1 ' hotkey control.
' %noimagelist = 1 ' imagelist apis.
%noipaddress = 1
%nolist = 1
' %nolistview = 1 ' listview control.
%nomenuhelp = 1 ' apis to help manage menus, especially with a status bar.
%nomonthcal = 1
%nomui = 1
%nonativefontctl = 1
%nopagescroller = 1
%noprogress = 1 ' progress gas gauge.
%norebar = 1
%nostatusbar = 1 ' status bar control.
%notabcontrol = 1
%notoolbar = 1 ' customizable bitmap-button toolbar control.
%notooltips = 1
%notrackbar = 1 ' customizable column-width tracking control.
%notreeview = 1 ' treeview control.
%noupdown = 1 ' up and down arrow increment/decrement control.
'
#include "win32api.inc"
#include "commctrl.inc"
'
%listviewgrid = 100
%exitbutton = 115
%vertscrollbar = 135
%horzscrollbar = 140
%extsel = 145
%extselset = 150
'
global hlistform& ' dialog handle
global hlistframe& ' dialog handle
global hlistwindow& ' 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 colwidth() as long ' column width array
global undolast() as string ' two-dimensional text array to store data prior to paste
global six as scrollinfo
global siy as scrollinfo
global goldsubclassproc&
global selx as long ' column selected
global sely as long ' row selected
global selectcol as long
global selectrow as long
global selectrowstart as long
global selectcolstart as long
global selymax&
global selymin&
global selxmax&
global selxmin&
global anchor&, undoflag&
global listviewheaderheight&,listviewitemheight&
global hmenuright&
global colextra&
' --------------------------------------------------------------------------------
callback function cbf_exit
local res&
res&=msgbox ("are you sure?",%mb_yesno or %mb_iconquestion ,"exit program?")
if res&=%idyes then dialog end hlistframe&
end function
' --------------------------------------------------------------------------------
function makefont(byval fonttypesize as long,byval fontweight as long, _
byval italic as long, byval underline as long,byval strikeout as long, _
byval facename as string) as long
local lffont as logfont, hdc as long,logpixelsy as long
hdc = getdc(%hwnd_desktop)
logpixelsy = getdevicecaps(hdc, %logpixelsy)
releasedc %hwnd_desktop, hdc
lffont.lfheight = -muldiv(fonttypesize,logpixelsy,72) ' logical height of font
lffont.lfwidth = 0 ' logical average character width
lffont.lfescapement = 0 ' angle of escapement
lffont.lforientation = 0 ' base-line orientation angle
lffont.lfweight = fontweight ' font weight
lffont.lfitalic = italic ' italic attribute flag (0,1)
lffont.lfunderline = underline ' underline attribute flag (0,1)
lffont.lfstrikeout = strikeout ' strikeout attribute flag (0,1)
lffont.lfcharset = %ansi_charset ' character set identifier
lffont.lfoutprecision = %out_tt_precis ' output precision
lffont.lfclipprecision = %clip_default_precis ' clipping precision
lffont.lfquality = %default_quality ' output quality
lffont.lfpitchandfamily = %ff_dontcare ' pitch and family
lffont.lffacename = facename ' typeface name string
function = createfontindirect (lffont)
end function
' --------------------------------------------------------------------------------
sub createdata(byref dataarray() as string,byref colwidth() as long,byref rows as long,byref columns as long)
local i&,j&
' fill array with data
for i&=0 to columns + colextra
if i = 0 then colwidth(i&) = 46 else colwidth(i&) = 150
for j&=0 to rows
if i&=0 then ' column zero is used for row headers.
if j&=0 then ' label of row header column.
dataarray(i&,j&)= "r\c"
else ' ' text of row headers.
if j<=rows then dataarray(i&,j&)= format$(j&)
end if
else ' i& >= 1
if j&=0 then ' row zero is used for column headers.
if i<= columns then dataarray(i&,j&)= format$(i&)
else ' j& >= 1 item/subitem content
if i& <= columns and j <= rows then dataarray(i&,j&)= "column"+str$(i&)+" row"+str$(j&)
end if
end if
next
next
end sub
' --------------------------------------------------------------------------------
' thanks to peter stephensen who provided the essential features of the following three functions.
function selectiontoclipboard(byref dataarray() as string, _
byval xmin as long, byval xmax as long, _
byval ymin as long, byval ymax as long) as long
mouseptr 11
local i as long, j as long
local s as string
for j = ymin to ymax
for i = xmin to xmax
if i < xmax then
s = s + dataarray(i,j) + $tab
else
s = s + dataarray(i,j) + $crlf
end if
next
next
local hglob as long
local hdata as long
' create a global memory object and copy the data into it
hdata = globalalloc(%gmem_moveable or %gmem_ddeshare, byval len(s)+1)
mouseptr 1
if isfalse hdata then exit function
hglob = globallock(hdata)
if isfalse hglob then exit function
movememory byval hglob, byval strptr(s), byval len(s)+1
globalunlock hdata
' open the clipboard
if isfalse(openclipboard(%null)) then globalfree hdata : exit function
' paste the data into the clipboard
if isfalse(emptyclipboard) then exit function
if isfalse(setclipboarddata(%cf_text, hdata)) then exit function
if isfalse(closeclipboard) then exit function
function = 1
end function
' --------------------------------------------------------------------------------
function textfromclipboard(txt as string) as long
local hdata as asciiz ptr
if openclipboard(%null) = 0 then exit function
hdata = getclipboarddata (%cf_text)
closeclipboard
txt = @hdata
function = 1
end function
' --------------------------------------------------------------------------------
function clipboardtogrid(byref dataarray() as string, _
byval xpos as long, byval ypos as long, _
byref xe as long,byref ye as long) as long
local buffer as string
local lines as long, tabs as long
local l as long, t as long, incomplflg&
if textfromclipboard(buffer) = 0 then exit function
mouseptr 11
lines = parsecount(buffer, $crlf) - 1
tabs = parsecount(parse$(buffer,$crlf,1), $tab)
xe = min(xpos+tabs-1,columns) : ye = min(ypos+lines-1,rows)
'
redim undolast(xpos to xe,ypos to ye)
for t = 0 to tabs-1
for l = 0 to lines-1
if (xpos+t) <= xe and (ypos+l) <= ye then
' save data in undolast array before pasting
undolast(xpos+t,ypos+l) = dataarray(xpos+t,ypos+l)
dataarray(xpos+t,ypos+l) = parse$(parse$(buffer,$crlf,l+1),$tab,t+1)
else
incomplflg& = 1
end if
next l
next t
mouseptr 1
undoflag& = 1
function = 1
if incomplflg& = 1 then function = 2
end function
' --------------------------------------------------------------------------------
function undolastpaste(byref a as long,byref b as long,byref c as long,byref d as long) as long
'selectcolstart, selectrowstart, selectcol, selectrow
local i&,j&
mouseptr 11
a = lbound(undolast) : c = ubound(undolast)
b = lbound(undolast(2)) : d = ubound(undolast(2))
for i = a to c
for j = b to d
' restore data prior to last paste
dataarray(i,j) = undolast(i,j)
next
next
mouseptr 1
undoflag& = 0
function = 1
end function
' --------------------------------------------------------------------------------
callback function listviewwindowcallback
' callback handle cbhndl is: hlistwindow&
local rc as rect
static ptscursor as pointapi
local szstring as asciiz * 256
local i&,kk&,result&,jj&,ll&
local headnotif as hd_notify ptr
local lvnotmes as nm_listview ptr
local pnmh as nmhdr ptr
local lplvdispinfo as lv_dispinfo ptr
local lplvcd as nmlvcustomdraw ptr
local res&
static hfatfont&, hnormfont&, hitalfont&, hheader&
'
select case cbmsg
case %wm_initdialog
'
getclientrect cbhndl, rc
hlistform& = createwindowex(0, "syslistview32", byval 0, _
%ws_child or %ws_visible or %lvs_report or %lvs_noscroll or %lvs_autoarrange or %lvs_ownerdata,0,0, _
rc.nright,rc.nbottom,cbhndl,%listviewgrid,getmodulehandle("),byval 0)
i = sendmessage (hlistform&, %listviewgrid, %lvm_getextendedlistviewstyle, 0)
' if you want gridlines, then uncomment the next line:
' i = i or %lvs_ex_gridlines
' nb: the %lvs_ex_fullrowselect listview style should not be used in this program.
sendmessage hlistform&, %lvm_setextendedlistviewstyle, 0, i
'
hnormfont& = makefont(9,400,0,0,0,"arial")
hfatfont& = makefont(9,700,0,0,0,"arial")
hitalfont& = makefont(9,400,1,0,0,"arial")
sendmessage hlistform&,%wm_setfont,hnormfont&,maklng(%true,0)
'
' set column header font
hheader& = listview_getheader(hlistform&)
sendmessage hheader&,%wm_setfont,hfatfont&,maklng(%true,0)
'
' define shortcut menu.
menu new popup to hmenuright&
menu add string, hmenuright&,"extended selection off",4,%mf_enabled
menu add string, hmenuright&,"extended selection on",2,%mf_enabled
menu add string, hmenuright&,"-",3,%mf_enabled
menu add string, hmenuright&,"select full row(s)",5,%mf_enabled
menu add string, hmenuright&,"select full column(s)",10,%mf_enabled
menu add string, hmenuright&,"-",12,%mf_enabled
menu add string, hmenuright&,"copy selection to clipboard",15,%mf_enabled
menu add string, hmenuright&,"paste from clipboard",20,%mf_enabled
menu add string, hmenuright&,"-",22,%mf_enabled
menu add string, hmenuright&,"undo last paste",25,%mf_enabled
menu attach hmenuright&, cbhndl
checkmenuitem hmenuright&,4,%mf_checked
'
' subclass listview
goldsubclassproc = setwindowlong(hlistform&,%gwl_wndproc, codeptr(subclasskeys))
'
case %wm_notify
if lowrd(cbwparam)= %listviewgrid then
lvnotmes = cblparam
select case @lvnotmes.hdr.code
case %nm_click ' left mouse button click
getcursorpos ptscursor
screentoclient hlistform&, ptscursor
kk& = (ptscursor.y - listviewheaderheight& - 1) \ listviewitemheight&
if @lvnotmes.isubitem > 1 then
selectrow = kk& + siy.npos
selectcol = max(six.npos + @lvnotmes.isubitem - 2,1)
if isfalse anchor then selectrowstart = selectrow : selectcolstart = selectcol
call updatecolumnsandscrollbars(six.npos,siy.npos)
end if
function = 1 : exit function
case %nm_rclick ' right mouse button click: display shortcut menu
getcursorpos ptscursor
if istrue isclipboardformatavailable(%cf_text) then ' can paste
enablemenuitem hmenuright&,20,%mf_enabled
else
enablemenuitem hmenuright&,20,%mf_grayed
end if
if istrue undoflag& then ' can undo
enablemenuitem hmenuright&,25,%mf_enabled
else
enablemenuitem hmenuright&,25,%mf_grayed
end if
trackpopupmenuex hmenuright&,%tpm_leftalign or %tpm_vertical or %tpm_leftbutton or %tpm_rightbutton ,ptscursor.x,ptscursor.y,cbhndl,byval %null
case %nm_customdraw
lplvcd = cblparam
if(@lplvcd.nmcd.dwdrawstage = %cdds_prepaint) then
' the following statement makes windows happy:
setwindowlong hlistwindow&,%dwl_msgresult,%cdrf_notifyitemdraw
' this statement makes the ddt engine happy:
function = 1: exit function
end if
if(@lplvcd.nmcd.dwdrawstage = %cdds_itemprepaint) then
setwindowlong hlistwindow&,%dwl_msgresult,%cdrf_notifysubitemdraw
function = 1: exit function
end if
if(@lplvcd.nmcd.dwdrawstage = %cdds_subitem or %cdds_itemprepaint) then
if @lplvcd.isubitem <= 1 then ' row header (or dummy column)
kk& = @lplvcd.nmcd.dwitemspec + siy.npos
if kk& mod 2 = 1 then @lplvcd.clrtextbk = %ltgray else @lplvcd.clrtextbk = rgb(210,210,210)
@lplvcd.clrtext = rgb(0,0,0) ' black
selectobject @lplvcd.nmcd.hdc, hfatfont&
else
kk& = @lplvcd.nmcd.dwitemspec + siy.npos
ll& = six.npos + @lplvcd.isubitem - 2
if kk = selectrowstart and ll = selectcolstart then
@lplvcd.clrtextbk = rgb(0,220,255)
@lplvcd.clrtext = 0 ' black
elseif kk >= selymin& and kk <= selymax& and ll >= selxmin& and ll <= selxmax& then
@lplvcd.clrtextbk = rgb(170,200,250)
@lplvcd.clrtext = 0 ' black
else
if kk& mod 2 = 1 then @lplvcd.clrtextbk = rgb(200,255,255) else @lplvcd.clrtextbk = rgb(255,255,255)
@lplvcd.clrtext = 0 ' black
end if
if ll& mod 2 = 1 then selectobject @lplvcd.nmcd.hdc, hnormfont& else selectobject @lplvcd.nmcd.hdc, hitalfont&
end if
setwindowlong hlistwindow&,%dwl_msgresult,(%cdrf_newfont or %cdrf_notifysubitemdraw)
function = 1: exit function
end if
case %lvn_getdispinfo 'virtual listview asks for item text
lplvdispinfo = cblparam
if (@lplvdispinfo.item.mask and %lvif_text) then
' specify text to be used
if @lplvdispinfo.item.isubitem = 1 then ' row header
szstring = dataarray(0 , @lplvdispinfo.item.iitem + siy.npos)'+1
elseif @lplvdispinfo.item.isubitem > 1 then ' column 1 and beyond
szstring = dataarray(@lplvdispinfo.item.isubitem + six.npos - 2 , @lplvdispinfo.item.iitem + siy.npos)
else
szstring = " ' dummy column
end if
@lplvdispinfo.item.psztext = varptr(szstring)
function = 1: exit function
end if
case else
end select
end if
'
headnotif = cblparam
if @headnotif.hdr.hwndfrom = hheader& then
if @headnotif.hdr.code = %hdn_itemchanged then
if @headnotif.iitem = 0 then ' maintain zero width of dummy column
result&=sendmessage(hlistform&,%lvm_getcolumnwidth, 0, 0)
if result&>0 then sendmessage hlistform&,%lvm_setcolumnwidth, 0, maklng(0, 0)
end if
end if
end if
case %wm_command ' right click menu
select case cbwparam
case 2 ' extended selection anchor on
anchor = 1
checkmenuitem hmenuright&,2,%mf_checked
checkmenuitem hmenuright&,4,%mf_unchecked
control set text hlistframe&,%extselset,"ext"
case 4 ' extended selection anchor off
anchor = 0
checkmenuitem hmenuright&,4,%mf_checked
checkmenuitem hmenuright&,2,%mf_unchecked
selectrow = selectrowstart : selectcol = selectcolstart
control set text hlistframe&,%extselset,"
call updatecolumnsandscrollbars(six.npos,siy.npos)
case 5 ' select full row(s)
selectcolstart = 1 : selectcol = columns
call updatecolumnsandscrollbars(six.npos,siy.npos)
case 10 ' select full column(s)
selectrowstart = 1 : selectrow = rows
call updatecolumnsandscrollbars(six.npos,siy.npos)
case 15 ' copy selected data to clipboard
anchor = 0
checkmenuitem hmenuright&,4,%mf_checked
checkmenuitem hmenuright&,2,%mf_unchecked
control set text hlistframe&,%extselset,"
res& = selectiontoclipboard(dataarray(),selxmin,selxmax,selymin,selymax)
if isfalse res& then msgbox "could not copy to clipboard",%mb_iconerror,"problem:"
case 20 ' paste clipboard data to grid at the focused cell
anchor = 0
checkmenuitem hmenuright&,4,%mf_checked
checkmenuitem hmenuright&,2,%mf_unchecked
control set text hlistframe&,%extselset,"
res& = clipboardtogrid(dataarray(),selectcolstart,selectrowstart,selectcol,selectrow)
call updatecolumnsandscrollbars(six.npos,siy.npos)
if isfalse res& then msgbox "could not paste from clipboard",%mb_iconerror,"problem:"
if res& = 2 then msgbox "not all data in clipboard could be pasted onto grid due to insufficient space",%mb_iconwarning,"notice:"
case 25 ' undo last paste to the grid
anchor = 0
checkmenuitem hmenuright&,4,%mf_checked
checkmenuitem hmenuright&,2,%mf_unchecked
control set text hlistframe&,%extselset,"
res& = undolastpaste(selectcolstart,selectrowstart,selectcol,selectrow)
call updatecolumnsandscrollbars(six.npos,siy.npos)
end select
case %wm_destroy
deleteobject hnormfont&
deleteobject hfatfont&
deleteobject hitalfont&
' important! remove the subclassing
setwindowlong hlistform&, %gwl_wndproc, goldsubclassproc
case else
end select
end function
' --------------------------------------------------------------------------------
callback function subclasskeys
' subclass callback function for processing key messages.
select case cbmsg
case %wm_getdlgcode
' specify that we want all keys available here.
function = %dlgc_wantallkeys: exit function
case %wm_keydown ' keys at time of pressing
select case cbwparam
case %vk_up
if selectrow > 1 then decr selectrow : siy.npos = min(siy.npos,selectrow)
if selectrow = siy.npos - 1 then decr siy.npos
if selectrow > siy.npos + pagerows then siy.npos = selectrow - pagerows + 1
if selectcol < six.npos then six.npos = selectcol
if selectcol > six.npos + pagecolumns then six.npos = selectcol - pagecolumns + 1
case %vk_down
if selectrow < rows then incr selectrow : siy.npos = min(siy.npos,selectrow)
if selectrow = siy.npos + pagerows then incr siy.npos
if selectrow > siy.npos + pagerows then siy.npos = selectrow - pagerows + 1
if selectcol < six.npos then six.npos = selectcol
if selectcol > six.npos + pagecolumns then six.npos = selectcol - pagecolumns + 1
case %vk_left
if selectcol > 1 then decr selectcol : six.npos = min(six.npos,selectcol)
if selectcol = six.npos - 1 then decr six.npos
if selectcol > six.npos + pagecolumns then six.npos = selectcol - pagecolumns + 1
if selectrow < siy.npos then siy.npos = selectrow
if selectrow > siy.npos + pagerows then siy.npos = selectrow - pagerows + 1
case %vk_right
if selectcol < columns then incr selectcol : six.npos = min(six.npos,selectcol)
if selectcol = six.npos + pagecolumns then incr six.npos
if selectcol > six.npos + pagecolumns then six.npos = selectcol - pagecolumns + 1
if selectrow < siy.npos then siy.npos = selectrow
if selectrow > siy.npos + pagerows then siy.npos = selectrow - pagerows + 1
case %vk_pgup
if selectrow = siy.npos then ' on the first visible line
siy.npos = siy.npos - siy.npage + 1
selectrow = siy.npos
end if
' not on the first display line: then move to that.
if selectrow > siy.npos then selectrow = siy.npos
selectrow = max(selectrow, siy.nmin)
case %vk_pgdn
if selectrow = siy.npos + siy.npage - 1 then ' on the last visible line
siy.npos = siy.npos + siy.npage - 1
selectrow = siy.npos + siy.npage - 1
end if
' not on the last display line: then move to that.
if selectrow < siy.npos + siy.npage - 1 then selectrow = siy.npos + siy.npage - 1
selectrow = min(selectrow, siy.nmax)
case %vk_home : six.npos = 1: siy.npos = 1 : selectrow = 1 : selectcol = 1
case %vk_end : six.npos = columns: siy.npos = rows : selectrow = rows : selectcol = columns
case %vk_f8 ' function key f8: anchor focus cell to enable extended selection
anchor = 1 : control set text hlistframe&,%extselset,"ext"
checkmenuitem hmenuright&,2,%mf_checked
checkmenuitem hmenuright&,4,%mf_unchecked
case else
end select
' 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))
if isfalse anchor then selectrowstart = selectrow : selectcolstart = selectcol
call updatecolumnsandscrollbars(six.npos,siy.npos)
case %wm_char
select case cbwparam
case %vk_escape
anchor = 0 : selectrow = selectrowstart : selectcol = selectcolstart
control set text hlistframe&,%extselset,"
checkmenuitem hmenuright&,4,%mf_checked
checkmenuitem hmenuright&,2,%mf_unchecked
call updatecolumnsandscrollbars(six.npos,siy.npos)
end select
end select
' pass the message on to the original window procedure... the ddt engine!
function = callwindowproc(goldsubclassproc, cbhndl, cbmsg, cbwparam, cblparam)
end function
' --------------------------------------------------------------------------------
sub definecolumns(byval xpos as long)
local lvc as lv_column
local ztext as asciiz * 100
local kk&
lvc.mask = %lvcf_fmt or %lvcf_width or %lvcf_text or %lvcf_subitem
lvc.cchtextmax = 100
' make the first column a 0 pixel wide empty dummy column.
' this prevents diplay of listview's "internal" selection cell.
' nb: the %lvs_ex_fullrowselect listview style should not be used.
lvc.cx = 0
lvc.fmt = %lvcfmt_left ' set justification
ztext = "
lvc.psztext = varptr(ztext)
sendmessage hlistform&,%lvm_insertcolumn, 0, varptr(lvc)
' make column headers
for kk& = xpos to xpos+pagecolumns+colextra-1 ' includes row header column
lvc.cx = colwidth(min(kk&-1,columns))
ztext = dataarray(min(kk&-1,columns),0)
lvc.psztext = varptr(ztext)
sendmessage hlistform&,%lvm_insertcolumn, kk&, varptr(lvc)
next
end sub
' --------------------------------------------------------------------------------
sub updatecolumnsandscrollbars(byval xpos as long,byval ypos as long)
static xprevpos as long,yprevpos as long ' previous positions (remember between calls)
local kk&, ztext as asciiz * 100, lvc as lv_column
lvc.mask = %lvcf_text or %lvcf_width
lvc.cchtextmax = 100
lvc.psztext = varptr(ztext)
setfocus hlistform&
'
' be sure that the dummy header column width is always kept at zero.
sendmessage hlistform&,%lvm_setcolumnwidth, 0, maklng(0, 0)
'
if xpos<>xprevpos then ' moved in x-direction (horizontal)
six.fmask = %sif_pos
control send hlistframe& , %horzscrollbar, %sbm_setscrollinfo, %true, varptr(six)
for kk& = xpos to xpos+pagecolumns+colextra
sendmessage hlistform&, %lvm_getcolumn, kk&-xpos+2, varptr(lvc)
lvc.cx = colwidth(kk&) : ztext = dataarray(kk&,0)
sendmessage hlistform&,%lvm_setcolumn, kk&-xpos+2, varptr(lvc)
next
end if
'
if ypos<>yprevpos then ' moved in y-direction (vertical)
siy.fmask = %sif_pos
control send hlistframe&, %vertscrollbar, %sbm_setscrollinfo, %true, varptr(siy)
end if
' get full selection outline.
selymax& = max(selectrowstart, selectrow)
selymin& = min(selectrowstart, selectrow)
selxmax& = max(selectcolstart, selectcol)
selxmin& = min(selectcolstart, selectcol)
'
invalidaterect hlistform&,byval %null,%false
yprevpos=ypos: xprevpos=xpos ' remember new previous positions
end sub
' --------------------------------------------------------------------------------
sub makelistviewwindow(byval hlistframe&)
local rc as rect
'
control add scrollbar,hlistframe&,%horzscrollbar,",0,0,0,0,%ws_child or %ws_visible or %sbs_horz
control add scrollbar,hlistframe&,%vertscrollbar,",0,0,0,0,%ws_child or %ws_visible or %sbs_vert
'
' define external horizontal scroll bar.
six.cbsize = sizeof(six)
six.fmask = %sif_all
six.nmin = 1
six.nmax = columns + colextra-1 ' some extra empty columns
six.npage = pagecolumns
six.npos = 1
control send hlistframe&, %horzscrollbar, %sbm_setscrollinfo, %false, varptr(six)
'
' define external vertical scroll bar.
siy.cbsize = sizeof(siy)
siy.fmask = %sif_all
siy.nmin = 1
siy.nmax = rows
siy.npage = pagerows
siy.npos = 1
control send hlistframe&, %vertscrollbar, %sbm_setscrollinfo, %false, varptr(siy)
' make "viewport" for the listview without scroll bars to be created
getclientrect hlistframe&, rc
dialog new hlistframe&, ",0,0,0,0, %ws_child or %ws_visible, to hlistwindow&
mo
' selection capability - for pbwin 6.x and 7.x.
'
' improved version july 12, 2003
'
' according to your need this skeleton code may be expanded
' with editing, sorting and mouse dragging facilities. the
' latter will probably need a mouse hook. the custom drawing
' allows each cell to have its own background and foreground
' color as well as its own font.
'
' at present there is only a modest utilization of such
' features. i leave further developments to you. you may see
' these links for previous colorful versions:
http://www.powerbasic.com/support/pb...ad.php?t=23229
http://www.powerbasic.com/support/pb...ad.php?t=24782
' the present version suppresses listview's built-in selection
' capability, which is limited either to the first column or
' to full rows. the suppression is done by omitting the
' %lvs_ex_fullrowselect style and maintaining a zero width
' of the first column. this makes it possible to devise
' selection of any group of cells to be copied to the
' clipboard and from there to other programs like word and
' excel. you can also copy the other way - e.g. from excel
' to the grid - via the clipboard. extended selection is
' invoked using f8 or via a shortcut menu obtained using
' the right mouse button. this menu is also used to select
' full rows and columns and for copying and pasting. the
' original format (font, alignment, color etc.) of the target
' cells is maintained after receiving the new data from the
' clipboard. only the content is changed.
' external scroll bars are replacing those of listview, which
' is defined using the %lvs_noscroll style. therefore
' listview needs only handle data being displayed at any
' one time plus a few extra columns as reserve. thus there
' is no limit to the number of rows and columns, which may
' be handled, other than the amount of available computer
' memory.
' since the virtual listview functions are not designed
' to work with the no-scroll style, the scroll messages
' need to be handled in a separate callback function to
' ensure smooth scrolling.
' in the present version alternate lines are given slightly
' different background colors. if you want grid-lines,
' these can easily be added by uncommenting this statement:
' "' i = i or %lvs_ex_gridlines" in callback function
' listviewwindowcallback.
' thanks to peter stephensen for the clipboard routines
' and to semen matusovski, david kenny, lance edmonds,
' borje hagsten and david l. morris for help in earlier
' virtual listview developmental phases.
' best of luck.
' erik christensen ------ [email protected] ------- june 21, 2003
'
' july 12, 2003: some improvements have been made: the line
' height has been increased using a technique provided by
' edwin knoppert. an undo last paste has been added and the
' key scrolling performance has been improved somewhat to
' approach that of excel. the program structure has also been
' changed slightly and the font has been changed to arial.
[CODE]
#compile exe
#register none
#dim all
'
' in this program only listview and header controls use the commctrl.inc file
%noanimate = 1 ' animate control.
%nobutton = 1
%nocombo = 1
%nodatetimepick = 1
%nodraglist = 1 ' apis to make a listbox source and sink drag&drop actions.
%noedit = 1
%noflatsbapis = 1
' %noheader = 1 ' header bar control.
%nohotkey = 1 ' hotkey control.
' %noimagelist = 1 ' imagelist apis.
%noipaddress = 1
%nolist = 1
' %nolistview = 1 ' listview control.
%nomenuhelp = 1 ' apis to help manage menus, especially with a status bar.
%nomonthcal = 1
%nomui = 1
%nonativefontctl = 1
%nopagescroller = 1
%noprogress = 1 ' progress gas gauge.
%norebar = 1
%nostatusbar = 1 ' status bar control.
%notabcontrol = 1
%notoolbar = 1 ' customizable bitmap-button toolbar control.
%notooltips = 1
%notrackbar = 1 ' customizable column-width tracking control.
%notreeview = 1 ' treeview control.
%noupdown = 1 ' up and down arrow increment/decrement control.
'
#include "win32api.inc"
#include "commctrl.inc"
'
%listviewgrid = 100
%exitbutton = 115
%vertscrollbar = 135
%horzscrollbar = 140
%extsel = 145
%extselset = 150
'
global hlistform& ' dialog handle
global hlistframe& ' dialog handle
global hlistwindow& ' 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 colwidth() as long ' column width array
global undolast() as string ' two-dimensional text array to store data prior to paste
global six as scrollinfo
global siy as scrollinfo
global goldsubclassproc&
global selx as long ' column selected
global sely as long ' row selected
global selectcol as long
global selectrow as long
global selectrowstart as long
global selectcolstart as long
global selymax&
global selymin&
global selxmax&
global selxmin&
global anchor&, undoflag&
global listviewheaderheight&,listviewitemheight&
global hmenuright&
global colextra&
' --------------------------------------------------------------------------------
callback function cbf_exit
local res&
res&=msgbox ("are you sure?",%mb_yesno or %mb_iconquestion ,"exit program?")
if res&=%idyes then dialog end hlistframe&
end function
' --------------------------------------------------------------------------------
function makefont(byval fonttypesize as long,byval fontweight as long, _
byval italic as long, byval underline as long,byval strikeout as long, _
byval facename as string) as long
local lffont as logfont, hdc as long,logpixelsy as long
hdc = getdc(%hwnd_desktop)
logpixelsy = getdevicecaps(hdc, %logpixelsy)
releasedc %hwnd_desktop, hdc
lffont.lfheight = -muldiv(fonttypesize,logpixelsy,72) ' logical height of font
lffont.lfwidth = 0 ' logical average character width
lffont.lfescapement = 0 ' angle of escapement
lffont.lforientation = 0 ' base-line orientation angle
lffont.lfweight = fontweight ' font weight
lffont.lfitalic = italic ' italic attribute flag (0,1)
lffont.lfunderline = underline ' underline attribute flag (0,1)
lffont.lfstrikeout = strikeout ' strikeout attribute flag (0,1)
lffont.lfcharset = %ansi_charset ' character set identifier
lffont.lfoutprecision = %out_tt_precis ' output precision
lffont.lfclipprecision = %clip_default_precis ' clipping precision
lffont.lfquality = %default_quality ' output quality
lffont.lfpitchandfamily = %ff_dontcare ' pitch and family
lffont.lffacename = facename ' typeface name string
function = createfontindirect (lffont)
end function
' --------------------------------------------------------------------------------
sub createdata(byref dataarray() as string,byref colwidth() as long,byref rows as long,byref columns as long)
local i&,j&
' fill array with data
for i&=0 to columns + colextra
if i = 0 then colwidth(i&) = 46 else colwidth(i&) = 150
for j&=0 to rows
if i&=0 then ' column zero is used for row headers.
if j&=0 then ' label of row header column.
dataarray(i&,j&)= "r\c"
else ' ' text of row headers.
if j<=rows then dataarray(i&,j&)= format$(j&)
end if
else ' i& >= 1
if j&=0 then ' row zero is used for column headers.
if i<= columns then dataarray(i&,j&)= format$(i&)
else ' j& >= 1 item/subitem content
if i& <= columns and j <= rows then dataarray(i&,j&)= "column"+str$(i&)+" row"+str$(j&)
end if
end if
next
next
end sub
' --------------------------------------------------------------------------------
' thanks to peter stephensen who provided the essential features of the following three functions.
function selectiontoclipboard(byref dataarray() as string, _
byval xmin as long, byval xmax as long, _
byval ymin as long, byval ymax as long) as long
mouseptr 11
local i as long, j as long
local s as string
for j = ymin to ymax
for i = xmin to xmax
if i < xmax then
s = s + dataarray(i,j) + $tab
else
s = s + dataarray(i,j) + $crlf
end if
next
next
local hglob as long
local hdata as long
' create a global memory object and copy the data into it
hdata = globalalloc(%gmem_moveable or %gmem_ddeshare, byval len(s)+1)
mouseptr 1
if isfalse hdata then exit function
hglob = globallock(hdata)
if isfalse hglob then exit function
movememory byval hglob, byval strptr(s), byval len(s)+1
globalunlock hdata
' open the clipboard
if isfalse(openclipboard(%null)) then globalfree hdata : exit function
' paste the data into the clipboard
if isfalse(emptyclipboard) then exit function
if isfalse(setclipboarddata(%cf_text, hdata)) then exit function
if isfalse(closeclipboard) then exit function
function = 1
end function
' --------------------------------------------------------------------------------
function textfromclipboard(txt as string) as long
local hdata as asciiz ptr
if openclipboard(%null) = 0 then exit function
hdata = getclipboarddata (%cf_text)
closeclipboard
txt = @hdata
function = 1
end function
' --------------------------------------------------------------------------------
function clipboardtogrid(byref dataarray() as string, _
byval xpos as long, byval ypos as long, _
byref xe as long,byref ye as long) as long
local buffer as string
local lines as long, tabs as long
local l as long, t as long, incomplflg&
if textfromclipboard(buffer) = 0 then exit function
mouseptr 11
lines = parsecount(buffer, $crlf) - 1
tabs = parsecount(parse$(buffer,$crlf,1), $tab)
xe = min(xpos+tabs-1,columns) : ye = min(ypos+lines-1,rows)
'
redim undolast(xpos to xe,ypos to ye)
for t = 0 to tabs-1
for l = 0 to lines-1
if (xpos+t) <= xe and (ypos+l) <= ye then
' save data in undolast array before pasting
undolast(xpos+t,ypos+l) = dataarray(xpos+t,ypos+l)
dataarray(xpos+t,ypos+l) = parse$(parse$(buffer,$crlf,l+1),$tab,t+1)
else
incomplflg& = 1
end if
next l
next t
mouseptr 1
undoflag& = 1
function = 1
if incomplflg& = 1 then function = 2
end function
' --------------------------------------------------------------------------------
function undolastpaste(byref a as long,byref b as long,byref c as long,byref d as long) as long
'selectcolstart, selectrowstart, selectcol, selectrow
local i&,j&
mouseptr 11
a = lbound(undolast) : c = ubound(undolast)
b = lbound(undolast(2)) : d = ubound(undolast(2))
for i = a to c
for j = b to d
' restore data prior to last paste
dataarray(i,j) = undolast(i,j)
next
next
mouseptr 1
undoflag& = 0
function = 1
end function
' --------------------------------------------------------------------------------
callback function listviewwindowcallback
' callback handle cbhndl is: hlistwindow&
local rc as rect
static ptscursor as pointapi
local szstring as asciiz * 256
local i&,kk&,result&,jj&,ll&
local headnotif as hd_notify ptr
local lvnotmes as nm_listview ptr
local pnmh as nmhdr ptr
local lplvdispinfo as lv_dispinfo ptr
local lplvcd as nmlvcustomdraw ptr
local res&
static hfatfont&, hnormfont&, hitalfont&, hheader&
'
select case cbmsg
case %wm_initdialog
'
getclientrect cbhndl, rc
hlistform& = createwindowex(0, "syslistview32", byval 0, _
%ws_child or %ws_visible or %lvs_report or %lvs_noscroll or %lvs_autoarrange or %lvs_ownerdata,0,0, _
rc.nright,rc.nbottom,cbhndl,%listviewgrid,getmodulehandle("),byval 0)
i = sendmessage (hlistform&, %listviewgrid, %lvm_getextendedlistviewstyle, 0)
' if you want gridlines, then uncomment the next line:
' i = i or %lvs_ex_gridlines
' nb: the %lvs_ex_fullrowselect listview style should not be used in this program.
sendmessage hlistform&, %lvm_setextendedlistviewstyle, 0, i
'
hnormfont& = makefont(9,400,0,0,0,"arial")
hfatfont& = makefont(9,700,0,0,0,"arial")
hitalfont& = makefont(9,400,1,0,0,"arial")
sendmessage hlistform&,%wm_setfont,hnormfont&,maklng(%true,0)
'
' set column header font
hheader& = listview_getheader(hlistform&)
sendmessage hheader&,%wm_setfont,hfatfont&,maklng(%true,0)
'
' define shortcut menu.
menu new popup to hmenuright&
menu add string, hmenuright&,"extended selection off",4,%mf_enabled
menu add string, hmenuright&,"extended selection on",2,%mf_enabled
menu add string, hmenuright&,"-",3,%mf_enabled
menu add string, hmenuright&,"select full row(s)",5,%mf_enabled
menu add string, hmenuright&,"select full column(s)",10,%mf_enabled
menu add string, hmenuright&,"-",12,%mf_enabled
menu add string, hmenuright&,"copy selection to clipboard",15,%mf_enabled
menu add string, hmenuright&,"paste from clipboard",20,%mf_enabled
menu add string, hmenuright&,"-",22,%mf_enabled
menu add string, hmenuright&,"undo last paste",25,%mf_enabled
menu attach hmenuright&, cbhndl
checkmenuitem hmenuright&,4,%mf_checked
'
' subclass listview
goldsubclassproc = setwindowlong(hlistform&,%gwl_wndproc, codeptr(subclasskeys))
'
case %wm_notify
if lowrd(cbwparam)= %listviewgrid then
lvnotmes = cblparam
select case @lvnotmes.hdr.code
case %nm_click ' left mouse button click
getcursorpos ptscursor
screentoclient hlistform&, ptscursor
kk& = (ptscursor.y - listviewheaderheight& - 1) \ listviewitemheight&
if @lvnotmes.isubitem > 1 then
selectrow = kk& + siy.npos
selectcol = max(six.npos + @lvnotmes.isubitem - 2,1)
if isfalse anchor then selectrowstart = selectrow : selectcolstart = selectcol
call updatecolumnsandscrollbars(six.npos,siy.npos)
end if
function = 1 : exit function
case %nm_rclick ' right mouse button click: display shortcut menu
getcursorpos ptscursor
if istrue isclipboardformatavailable(%cf_text) then ' can paste
enablemenuitem hmenuright&,20,%mf_enabled
else
enablemenuitem hmenuright&,20,%mf_grayed
end if
if istrue undoflag& then ' can undo
enablemenuitem hmenuright&,25,%mf_enabled
else
enablemenuitem hmenuright&,25,%mf_grayed
end if
trackpopupmenuex hmenuright&,%tpm_leftalign or %tpm_vertical or %tpm_leftbutton or %tpm_rightbutton ,ptscursor.x,ptscursor.y,cbhndl,byval %null
case %nm_customdraw
lplvcd = cblparam
if(@lplvcd.nmcd.dwdrawstage = %cdds_prepaint) then
' the following statement makes windows happy:
setwindowlong hlistwindow&,%dwl_msgresult,%cdrf_notifyitemdraw
' this statement makes the ddt engine happy:
function = 1: exit function
end if
if(@lplvcd.nmcd.dwdrawstage = %cdds_itemprepaint) then
setwindowlong hlistwindow&,%dwl_msgresult,%cdrf_notifysubitemdraw
function = 1: exit function
end if
if(@lplvcd.nmcd.dwdrawstage = %cdds_subitem or %cdds_itemprepaint) then
if @lplvcd.isubitem <= 1 then ' row header (or dummy column)
kk& = @lplvcd.nmcd.dwitemspec + siy.npos
if kk& mod 2 = 1 then @lplvcd.clrtextbk = %ltgray else @lplvcd.clrtextbk = rgb(210,210,210)
@lplvcd.clrtext = rgb(0,0,0) ' black
selectobject @lplvcd.nmcd.hdc, hfatfont&
else
kk& = @lplvcd.nmcd.dwitemspec + siy.npos
ll& = six.npos + @lplvcd.isubitem - 2
if kk = selectrowstart and ll = selectcolstart then
@lplvcd.clrtextbk = rgb(0,220,255)
@lplvcd.clrtext = 0 ' black
elseif kk >= selymin& and kk <= selymax& and ll >= selxmin& and ll <= selxmax& then
@lplvcd.clrtextbk = rgb(170,200,250)
@lplvcd.clrtext = 0 ' black
else
if kk& mod 2 = 1 then @lplvcd.clrtextbk = rgb(200,255,255) else @lplvcd.clrtextbk = rgb(255,255,255)
@lplvcd.clrtext = 0 ' black
end if
if ll& mod 2 = 1 then selectobject @lplvcd.nmcd.hdc, hnormfont& else selectobject @lplvcd.nmcd.hdc, hitalfont&
end if
setwindowlong hlistwindow&,%dwl_msgresult,(%cdrf_newfont or %cdrf_notifysubitemdraw)
function = 1: exit function
end if
case %lvn_getdispinfo 'virtual listview asks for item text
lplvdispinfo = cblparam
if (@lplvdispinfo.item.mask and %lvif_text) then
' specify text to be used
if @lplvdispinfo.item.isubitem = 1 then ' row header
szstring = dataarray(0 , @lplvdispinfo.item.iitem + siy.npos)'+1
elseif @lplvdispinfo.item.isubitem > 1 then ' column 1 and beyond
szstring = dataarray(@lplvdispinfo.item.isubitem + six.npos - 2 , @lplvdispinfo.item.iitem + siy.npos)
else
szstring = " ' dummy column
end if
@lplvdispinfo.item.psztext = varptr(szstring)
function = 1: exit function
end if
case else
end select
end if
'
headnotif = cblparam
if @headnotif.hdr.hwndfrom = hheader& then
if @headnotif.hdr.code = %hdn_itemchanged then
if @headnotif.iitem = 0 then ' maintain zero width of dummy column
result&=sendmessage(hlistform&,%lvm_getcolumnwidth, 0, 0)
if result&>0 then sendmessage hlistform&,%lvm_setcolumnwidth, 0, maklng(0, 0)
end if
end if
end if
case %wm_command ' right click menu
select case cbwparam
case 2 ' extended selection anchor on
anchor = 1
checkmenuitem hmenuright&,2,%mf_checked
checkmenuitem hmenuright&,4,%mf_unchecked
control set text hlistframe&,%extselset,"ext"
case 4 ' extended selection anchor off
anchor = 0
checkmenuitem hmenuright&,4,%mf_checked
checkmenuitem hmenuright&,2,%mf_unchecked
selectrow = selectrowstart : selectcol = selectcolstart
control set text hlistframe&,%extselset,"
call updatecolumnsandscrollbars(six.npos,siy.npos)
case 5 ' select full row(s)
selectcolstart = 1 : selectcol = columns
call updatecolumnsandscrollbars(six.npos,siy.npos)
case 10 ' select full column(s)
selectrowstart = 1 : selectrow = rows
call updatecolumnsandscrollbars(six.npos,siy.npos)
case 15 ' copy selected data to clipboard
anchor = 0
checkmenuitem hmenuright&,4,%mf_checked
checkmenuitem hmenuright&,2,%mf_unchecked
control set text hlistframe&,%extselset,"
res& = selectiontoclipboard(dataarray(),selxmin,selxmax,selymin,selymax)
if isfalse res& then msgbox "could not copy to clipboard",%mb_iconerror,"problem:"
case 20 ' paste clipboard data to grid at the focused cell
anchor = 0
checkmenuitem hmenuright&,4,%mf_checked
checkmenuitem hmenuright&,2,%mf_unchecked
control set text hlistframe&,%extselset,"
res& = clipboardtogrid(dataarray(),selectcolstart,selectrowstart,selectcol,selectrow)
call updatecolumnsandscrollbars(six.npos,siy.npos)
if isfalse res& then msgbox "could not paste from clipboard",%mb_iconerror,"problem:"
if res& = 2 then msgbox "not all data in clipboard could be pasted onto grid due to insufficient space",%mb_iconwarning,"notice:"
case 25 ' undo last paste to the grid
anchor = 0
checkmenuitem hmenuright&,4,%mf_checked
checkmenuitem hmenuright&,2,%mf_unchecked
control set text hlistframe&,%extselset,"
res& = undolastpaste(selectcolstart,selectrowstart,selectcol,selectrow)
call updatecolumnsandscrollbars(six.npos,siy.npos)
end select
case %wm_destroy
deleteobject hnormfont&
deleteobject hfatfont&
deleteobject hitalfont&
' important! remove the subclassing
setwindowlong hlistform&, %gwl_wndproc, goldsubclassproc
case else
end select
end function
' --------------------------------------------------------------------------------
callback function subclasskeys
' subclass callback function for processing key messages.
select case cbmsg
case %wm_getdlgcode
' specify that we want all keys available here.
function = %dlgc_wantallkeys: exit function
case %wm_keydown ' keys at time of pressing
select case cbwparam
case %vk_up
if selectrow > 1 then decr selectrow : siy.npos = min(siy.npos,selectrow)
if selectrow = siy.npos - 1 then decr siy.npos
if selectrow > siy.npos + pagerows then siy.npos = selectrow - pagerows + 1
if selectcol < six.npos then six.npos = selectcol
if selectcol > six.npos + pagecolumns then six.npos = selectcol - pagecolumns + 1
case %vk_down
if selectrow < rows then incr selectrow : siy.npos = min(siy.npos,selectrow)
if selectrow = siy.npos + pagerows then incr siy.npos
if selectrow > siy.npos + pagerows then siy.npos = selectrow - pagerows + 1
if selectcol < six.npos then six.npos = selectcol
if selectcol > six.npos + pagecolumns then six.npos = selectcol - pagecolumns + 1
case %vk_left
if selectcol > 1 then decr selectcol : six.npos = min(six.npos,selectcol)
if selectcol = six.npos - 1 then decr six.npos
if selectcol > six.npos + pagecolumns then six.npos = selectcol - pagecolumns + 1
if selectrow < siy.npos then siy.npos = selectrow
if selectrow > siy.npos + pagerows then siy.npos = selectrow - pagerows + 1
case %vk_right
if selectcol < columns then incr selectcol : six.npos = min(six.npos,selectcol)
if selectcol = six.npos + pagecolumns then incr six.npos
if selectcol > six.npos + pagecolumns then six.npos = selectcol - pagecolumns + 1
if selectrow < siy.npos then siy.npos = selectrow
if selectrow > siy.npos + pagerows then siy.npos = selectrow - pagerows + 1
case %vk_pgup
if selectrow = siy.npos then ' on the first visible line
siy.npos = siy.npos - siy.npage + 1
selectrow = siy.npos
end if
' not on the first display line: then move to that.
if selectrow > siy.npos then selectrow = siy.npos
selectrow = max(selectrow, siy.nmin)
case %vk_pgdn
if selectrow = siy.npos + siy.npage - 1 then ' on the last visible line
siy.npos = siy.npos + siy.npage - 1
selectrow = siy.npos + siy.npage - 1
end if
' not on the last display line: then move to that.
if selectrow < siy.npos + siy.npage - 1 then selectrow = siy.npos + siy.npage - 1
selectrow = min(selectrow, siy.nmax)
case %vk_home : six.npos = 1: siy.npos = 1 : selectrow = 1 : selectcol = 1
case %vk_end : six.npos = columns: siy.npos = rows : selectrow = rows : selectcol = columns
case %vk_f8 ' function key f8: anchor focus cell to enable extended selection
anchor = 1 : control set text hlistframe&,%extselset,"ext"
checkmenuitem hmenuright&,2,%mf_checked
checkmenuitem hmenuright&,4,%mf_unchecked
case else
end select
' 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))
if isfalse anchor then selectrowstart = selectrow : selectcolstart = selectcol
call updatecolumnsandscrollbars(six.npos,siy.npos)
case %wm_char
select case cbwparam
case %vk_escape
anchor = 0 : selectrow = selectrowstart : selectcol = selectcolstart
control set text hlistframe&,%extselset,"
checkmenuitem hmenuright&,4,%mf_checked
checkmenuitem hmenuright&,2,%mf_unchecked
call updatecolumnsandscrollbars(six.npos,siy.npos)
end select
end select
' pass the message on to the original window procedure... the ddt engine!
function = callwindowproc(goldsubclassproc, cbhndl, cbmsg, cbwparam, cblparam)
end function
' --------------------------------------------------------------------------------
sub definecolumns(byval xpos as long)
local lvc as lv_column
local ztext as asciiz * 100
local kk&
lvc.mask = %lvcf_fmt or %lvcf_width or %lvcf_text or %lvcf_subitem
lvc.cchtextmax = 100
' make the first column a 0 pixel wide empty dummy column.
' this prevents diplay of listview's "internal" selection cell.
' nb: the %lvs_ex_fullrowselect listview style should not be used.
lvc.cx = 0
lvc.fmt = %lvcfmt_left ' set justification
ztext = "
lvc.psztext = varptr(ztext)
sendmessage hlistform&,%lvm_insertcolumn, 0, varptr(lvc)
' make column headers
for kk& = xpos to xpos+pagecolumns+colextra-1 ' includes row header column
lvc.cx = colwidth(min(kk&-1,columns))
ztext = dataarray(min(kk&-1,columns),0)
lvc.psztext = varptr(ztext)
sendmessage hlistform&,%lvm_insertcolumn, kk&, varptr(lvc)
next
end sub
' --------------------------------------------------------------------------------
sub updatecolumnsandscrollbars(byval xpos as long,byval ypos as long)
static xprevpos as long,yprevpos as long ' previous positions (remember between calls)
local kk&, ztext as asciiz * 100, lvc as lv_column
lvc.mask = %lvcf_text or %lvcf_width
lvc.cchtextmax = 100
lvc.psztext = varptr(ztext)
setfocus hlistform&
'
' be sure that the dummy header column width is always kept at zero.
sendmessage hlistform&,%lvm_setcolumnwidth, 0, maklng(0, 0)
'
if xpos<>xprevpos then ' moved in x-direction (horizontal)
six.fmask = %sif_pos
control send hlistframe& , %horzscrollbar, %sbm_setscrollinfo, %true, varptr(six)
for kk& = xpos to xpos+pagecolumns+colextra
sendmessage hlistform&, %lvm_getcolumn, kk&-xpos+2, varptr(lvc)
lvc.cx = colwidth(kk&) : ztext = dataarray(kk&,0)
sendmessage hlistform&,%lvm_setcolumn, kk&-xpos+2, varptr(lvc)
next
end if
'
if ypos<>yprevpos then ' moved in y-direction (vertical)
siy.fmask = %sif_pos
control send hlistframe&, %vertscrollbar, %sbm_setscrollinfo, %true, varptr(siy)
end if
' get full selection outline.
selymax& = max(selectrowstart, selectrow)
selymin& = min(selectrowstart, selectrow)
selxmax& = max(selectcolstart, selectcol)
selxmin& = min(selectcolstart, selectcol)
'
invalidaterect hlistform&,byval %null,%false
yprevpos=ypos: xprevpos=xpos ' remember new previous positions
end sub
' --------------------------------------------------------------------------------
sub makelistviewwindow(byval hlistframe&)
local rc as rect
'
control add scrollbar,hlistframe&,%horzscrollbar,",0,0,0,0,%ws_child or %ws_visible or %sbs_horz
control add scrollbar,hlistframe&,%vertscrollbar,",0,0,0,0,%ws_child or %ws_visible or %sbs_vert
'
' define external horizontal scroll bar.
six.cbsize = sizeof(six)
six.fmask = %sif_all
six.nmin = 1
six.nmax = columns + colextra-1 ' some extra empty columns
six.npage = pagecolumns
six.npos = 1
control send hlistframe&, %horzscrollbar, %sbm_setscrollinfo, %false, varptr(six)
'
' define external vertical scroll bar.
siy.cbsize = sizeof(siy)
siy.fmask = %sif_all
siy.nmin = 1
siy.nmax = rows
siy.npage = pagerows
siy.npos = 1
control send hlistframe&, %vertscrollbar, %sbm_setscrollinfo, %false, varptr(siy)
' make "viewport" for the listview without scroll bars to be created
getclientrect hlistframe&, rc
dialog new hlistframe&, ",0,0,0,0, %ws_child or %ws_visible, to hlistwindow&
mo
Comment