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

DDT Virtual Listview With Row Header, Fonts, Colors and Edit

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

  • DDT Virtual Listview With Row Header, Fonts, Colors and Edit

    ' ddt virtual listview with row header, fonts, colors and edit.

    ' this is a further development of virtual listview with row headers
    ' version 3. i thank very much for all the inspiration and feedback
    ' received from the forum, in particular for this version from semen
    ' matusovski, david kenny, lance edmonds and roberto valois.
    '
    ' this version is developed entirely using ddt. the capacity is only
    ' limited by the amount of the memory available in the system. that is
    ' you can have any number of rows and columns in the data array which
    ' holds the data. this particular version uses the internal vertical
    ' scroll bar of listview, but maintains an external horizontal scroll
    ' bar. with this arrangement the scrolling performance is not affected
    ' by the number of columns being high. listview is only handling the
    ' items/subitems being displayed at any time. this limits the amount of
    ' work needed and thereby the performance is improved.
    '
    ' any ideas for further improvement are most welcome here:
    http://www.powerbasic.com/support/pb...ad.php?t=18962
    '
    ' best wishes
    '
    ' erik christensen, copenhagen, denmark ----- e.chr@email.dk
    '
    ' p.s. some improvements have been made november 19th.
    ' a few further improvements have been made december 1st.
    [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"
    '
    %listviewgrid = 100
    %exitbutton = 115
    %vertscrollbar = 135
    %horzscrollbar = 140
    %editdescript = 145
    '
    %editlabel = 400
    %edittext = 410
    %editok = 415
    %editcancel = 420
    '
    %labelradiobuttonaction = 600
    %radiobuttonfinishediting = 605
    %radiobuttoneditright = 610
    %radiobuttoneditbelow = 615
    ' --------------------------------------------------
    declare sub showlistdialog(byval hparent&)
    declare callback function cbf_exit()
    declare callback function listframecallback()
    declare callback function listviewwindowcallback()
    declare sub updatecolumnsandhorzscrollbar (byval xpos as long)
    '
    declare callback function editdialogproc
    declare callback function cbf_edittext()
    declare callback function cbf_editok()
    declare callback function cbf_editcancel()
    '
    declare callback function cbf_radiobuttonfinishedit()
    declare callback function cbf_radiobuttoneditright()
    declare callback function cbf_radiobuttoneditbelow()
    '
    declare 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
    ' --------------------------------------------------
    global brush&
    global hlistform& ' dialog handle
    global hlistframe& ' dialog handle
    global hlistwindow& ' 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 colwidth() as long ' column width array

    global six as scrollinfo
    global goldsubclassproc&
    global goldsubclassedit&
    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
    '
    global rainbowcolors() as long
    global textcolor() as long
    global textfont() as long
    ' --------------------------------------------------
    '
    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/ycr!
    end function
    '
    ' --------------------------------------------------
    function pbmain
    local hdc as long
    local style&, exstyle&
    local x&,y&,x1&,y1&,hdlg&
    local cc1 as init_common_controlsex
    cc1.dwsize=sizeof(cc1)
    cc1.dwicc=%icc_win95_classes
    initcommoncontrolsex cc1
    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
    ' accomodation of small and big fonts windows settings
    ' may be improved
    if xcr!<1.75 then ycr!=1.87 else ycr!=1.90
    '
    style& = %ws_popup or %ds_modalframe or %ws_caption or %ws_minimizebox or %ws_sysmenu or %ds_center
    exstyle& = 0
    ' create frame window with horizontal scroll bar etc.
    dialog new 0, "virtual listview with integrated row header", 0, 0,xdu(98),ydu(92), style&, exstyle& to hlistframe&
    control add scrollbar, hlistframe&,%horzscrollbar," ,xdu(20.0),ydu(66.0),xdu(70.62),ydu(3.7), _
    %ws_child or %ws_visible or %sbs_horz
    control add button, hlistframe&, %exitbutton, "e&xit",xdu(80),ydu(75),xdu(10),ydu(4.43), _
    %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_exit
    control add label, hlistframe&, %editdescript,"double-click to edit cell", xdu(35),ydu(75),xdu(35),ydu(4.43), _
    %ws_child or %ws_visible or %ss_center
    dialog show modal hlistframe& call listframecallback
    ' handle of original frame window is: hlistframe&
    end function
    ' --------------------------------------------------
    callback function listframecallback
    'cbhndl = hlistframe&
    local i&,j&
    select case cbmsg
    case %wm_initdialog
    ' specification of size of array.
    ' you may test other sizes.
    rows=100
    columns=500
    '
    ' grid routines are made for arrays no less than (5,20)
    columns=max(5,columns)
    rows=max(20,rows)

    redim dataarray(0:columns,0:rows)' column zero and row zero are used for headers.
    redim colwidth(0:columns) ' each column may have it own width if you want that at some time.
    ' fill array with data
    for i&=0 to columns
    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&)= " row"
    else ' ' text of row headers.
    dataarray(i&,j&)= " row"+str$(j&)
    end if
    else ' i& >= 1
    if j&=0 then ' row zero is used for column headers.
    dataarray(i&,j&)= " column"+str$(i&)
    else ' j& >= 1 item/subitem content
    dataarray(i&,j&)= " column"+str$(i&)+" row"+str$(j&)
    end if
    end if
    next
    next
    '
    ' 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 external horizontal scrollbar.
    ' the build-in horizontal scrollbar of listview is not used.
    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)
    '
    ' the build-in vertical scrollbar of listview is being used.
    '
    ' make "viewport" for the listview to be created
    dialog new cbhndl, ", xdu(1.8),ydu(2.9),xdu(91.1),ydu(63.5), %ws_child or %ws_visible, to hlistwindow&
    ' make this dialog modeless
    dialog show modeless hlistwindow& call listviewwindowcallback
    '
    ' define columns in listview
    call definecolumns(six.npos)
    '
    call specifydatacolorsandfonts
    '
    setfocus hlistwindow&
    '
    function=1: exit function
    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_thumbposition ,%sb_thumbtrack
    ' 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))
    call updatecolumnsandhorzscrollbar(six.npos)
    function=1: exit function
    end select
    end function
    ' --------------------------------------------------
    callback function listviewwindowcallback
    ' callback handle cbhndl is: hlistwindow&
    local rc as rect
    local szstring as asciiz * 256
    local i&,kk&,result&
    static jj&
    local my_lplvnm as nm_listview ptr
    local pnmh as nmhdr ptr
    local lplvdispinfo as lv_dispinfo ptr
    local lplvcd as nmlvcustomdraw ptr
    local lvrow as long, lvcol as long
    static timeflagc as single
    local timec as single
    select case cbmsg
    case %wm_initdialog
    '
    getclientrect cbhndl, rc
    '
    ' dimension colwidths such that the sum of any displayed sets
    ' of columns (including the row header column) is one pixel
    ' larger than the horizontal dimension of the listview display
    ' minus the vertical scroll bar. this has the effect of having
    ' a hidden internal horizontal listview scroll bar made. this
    ' ensures that the bottom line will not go below the lower edge
    ' of the listview viewport.
    kk&=rc.nright-rc.nleft-getsystemmetrics(%sm_cyvscroll)
    jj&=kk& \(pagecolumns+1)
    kk&=kk&-pagecolumns*jj&+1
    for i&=0 to columns
    if i&=0 then colwidth(i&)= kk& else colwidth(i&)=jj&
    next
    '
    ' ******* this code is due to semen matusovski **************
    '
    ' make listview control with internal horizontal scroll bar outside the
    ' the edge of the created viewport. this has the effect of
    ' effectively hiding the internal horizontal scroll bar.

    hlistform& = createwindowex(0, "syslistview32", byval 0, _
    %ws_child or %ws_visible or %lvs_report or %lvs_autoarrange or %lvs_ownerdata , 0, 0, _
    rc.nright, rc.nbottom + getsystemmetrics(%sm_cyhscroll), _
    cbhndl, %listviewgrid, getmodulehandle("), byval 0)
    ' the %lvs_ownerdata style means that listview will request
    ' items when needed through %lvn_getdispinfo message.
    '
    i = sendmessage (hlistform&, %listviewgrid, %lvm_getextendedlistviewstyle, 0)
    i = i or %lvs_ex_gridlines or %lvs_ex_fullrowselect
    sendmessage hlistform&, %lvm_setextendedlistviewstyle, 0, i
    '
    getclientrect hlistform&, rc
    ' ***********************************************************
    '
    ' subclass %listviewgrid
    goldsubclassproc = setwindowlong(hlistform&,%gwl_wndproc, codeptr(subclasskeys))
    '
    case %wm_notify
    select case lowrd(cbwparam)
    case %listviewgrid
    ' this double click section has been inspired by the
    ' code by david l morris.
    my_lplvnm = cblparam
    select case @my_lplvnm.hdr.code
    case %nm_dblclk
    'case %nm_click ' you can use single click instead if you wnat
    'cursor position
    lvrow = @my_lplvnm.iitem
    lvcol = @my_lplvnm.isubitem
    ' get array indices corresponding to selected cell
    selx = six.npos+lvcol-1 ' adjust for presence of "internal" row header
    sely = lvrow+1
    if lvcol>0 then call editcellform(hlistform&) ' edit cell - new text to data array
    setfocus hlistform&
    function = 1
    exit function
    case %nm_customdraw
    ' this section is inspired by feedback from
    ' semen matusovski, david kenny and lance edmonds
    lplvcd = cblparam
    if(@lplvcd.nmcd.dwdrawstage = %cdds_prepaint) then
    ' the following statement ensures that the relevant
    ' messages are coming back to windows, so windows
    ' can respond appropriately. this method may be useful
    ' in many other situations where the ddt engine may
    ' swallow the information.
    ' 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 = 0 then ' row header
    ' specify background color
    @lplvcd.clrtextbk = rgb(235,235,235) ' light gray
    ' specify text color
    @lplvcd.clrtext = rgb(0,0,0) ' black
    ' specify font
    selectobject @lplvcd.nmcd.hdc, textfont(17)
    else ' column 1 and beyond
    kk& = @lplvcd.nmcd.dwitemspec + @lplvcd.isubitem + six.npos
    ' specify background color
    @lplvcd.clrtextbk = rainbowcolors(kk& mod 72)
    ' specify text color
    @lplvcd.clrtext = textcolor(kk& mod 72)
    ' specify font
    selectobject @lplvcd.nmcd.hdc, textfont(kk& mod 29)
    end if
    setwindowlong hlistwindow&,%dwl_msgresult,(%cdrf_newfont)' or %cdrf_notifysubitemdraw)
    function = 1: exit function
    end if
    case %lvn_getdispinfo 'virtual listview ask for item text
    lplvdispinfo = cblparam
    if (@lplvdispinfo.item.mask and %lvif_text) then
    ' specify text to be used
    if @lplvdispinfo.item.isubitem = 0 then ' row header
    szstring = dataarray(0 , @lplvdispinfo.item.iitem + 1)
    else ' column 1 and beyond
    szstring = dataarray(@lplvdispinfo.item.isubitem + six.npos - 1 , @lplvdispinfo.item.iitem + 1)
    end if
    @lplvdispinfo.item.psztext = varptr(szstring)
    function = 1: exit function
    end if
    case else
    ' maintain column width at original setting.
    ' this arrangement means the following few lines are
    ' executed only at 0.6 seconds interval at the most.
    timec=timer
    if timec-timeflagc > 0.6 then
    result&=sendmessage(hlistform&,%lvm_getcolumnwidth, 0, 0)
    if result&<colwidth(0) then
    sendmessage hlistform&,%lvm_setcolumnwidth, 0, maklng(colwidth(0), 0) ' row header
    invalidaterect hlistform&,byval %null,%false
    else
    for kk& = six.npos to six.npos+pagecolumns-1
    result&=sendmessage(hlistform&,%lvm_getcolumnwidth,kk&-six.npos+1, 0)
    if result&<colwidth(kk&) then
    sendmessage hlistform&,%lvm_setcolumnwidth,kk&-six.npos+1, maklng(colwidth(kk&), 0)
    invalidaterect hlistform&,byval %null,%false
    end if
    next
    end if
    timeflagc = timer
    end if
    end select
    end select
    case %wm_destroy
    for i=0 to 28 ' delete fonts that have been made.
    call deleteobject (textfont(i&))
    next
    ' 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.
    ' 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
    select case cbwparam
    case %vk_left : decr six.npos
    case %vk_right : incr six.npos
    case %vk_home : six.npos = 0
    case %vk_end : six.npos = columns
    case else : exit select
    end select
    ' ensure that positions are within range
    six.npos = max&(six.nmin, min&(six.npos, six.nmax - six.npage + 1))
    call updatecolumnsandhorzscrollbar(six.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 setcolumntext(byval colpos as long,byval arraypos as long,byval txt as string)
    local ztext as asciiz * 100
    local lvc as lv_column
    lvc.mask = %lvcf_text or %lvcf_width 'or %lvcf_subitem or %lvcf_fmt
    ' get relevant data about column structure
    sendmessage hlistform&, %lvm_getcolumn, colpos, varptr(lvc)
    lvc.cx = colwidth(arraypos) ' make sure to maintain original column width
    ztext = txt
    lvc.psztext = varptr(ztext)
    ' send new text to column
    sendmessage hlistform&,%lvm_setcolumn, colpos, varptr(lvc)
    end sub
    ' ------------------------------------------------
    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 column headers
    for kk& = xpos to xpos+pagecolumns ' includes row header column
    lvc.cx = colwidth(kk&-1)
    ' column header text
    lvc.fmt = %lvcfmt_left ' set justification
    ztext = dataarray(kk&-1,0)
    lvc.psztext = varptr(ztext)
    sendmessage hlistform&,%lvm_insertcolumn, kk&, varptr(lvc)
    next
    '
    ' dimension the listview in regard to total number of rows.
    ' this includes dimensioning of the internal vertical scroll bar
    ' of listview which we use. thus no external vertical
    ' scroll bar is necessary in this program.
    listview_setitemcountex hlistform&,rows,%lvsicf_noinvalidateall
    end sub
    ' ------------------------------------------------
    sub updatecolumnsandhorzscrollbar(byval xpos as long)
    local kk&
    static xprevpos as long ' previous x-position (remember between calls)
    setfocus hlistform&
    '
    if xpos<>xprevpos then ' moved in x-direction (horizontal)
    ' update horizontal scroll bar
    six.fmask = %sif_pos
    control send hlistframe& , %horzscrollbar, %sbm_setscrollinfo, %true, varptr(six)
    ' set row header coloumn width to ensure it is kept constant
    sendmessage hlistform&,%lvm_setcolumnwidth, 0, maklng(colwidth(0), 0)
    ' update column headers
    for kk& = xpos to xpos+pagecolumns-1
    call setcolumntext(kk&-xpos+1,kk&,dataarray(kk&,0))
    next
    ' force updating of listview to be made
    invalidaterect hlistform&,byval %null,%false
    end if
    xprevpos=xpos ' remember new previous x-position
    end sub
    ' ------------------------------------------------
    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
    ' --------------------------------------------------------------
    sub specifydatacolorsandfonts
    local i&,j&, red&, green&, blue&,kk&,ii&,k&,l&,m&,jj&
    redim rainbowcolors(0:71)
    redim textcolor(0:71)
    redim textfont (0:28)
    for i&=0 to 359 step 5 ' one 360 degrees turn (color loop)
    call getrainbowrgb(byref i&,byref red&,byref green&,byref blue&)
    rainbowcolors(i/5)=rgb(red&,green&,blue&)
    ' decide from color if text should be black or white
    ' this function is suited when transformation to a grey scale is needed.
    if red&*.222+green&*.707+blue&*.071>128 then ' color is light,
    textcolor(i/5)=rgb(0,0,0) ' then text should be black.
    else ' color is dark,
    textcolor(i/5)=rgb(255,255,255) ' then text should be white.
    end if
    next
    i&=0 : textfont(i)=makefont(8,700,0,0,0,"papyrus")
    incr i& : textfont(i)=makefont(8,600,0,0,0,"tempus sans itc")
    incr i& : textfont(i)=makefont(9,400,0,0,0,"klang mt")
    incr i& : textfont(i)=makefont(9,400,0,0,0,"eras medium itc")
    incr i& : textfont(i)=makefont(11,400,0,0,0,"edwardian script itc")
    for k&=400 to 700 step 300 ' font weight loop - normal or bold
    for l&=0 to 1 ' italic loop - normal or italic
    for m&=0 to 1 ' underline loop - normal or underline
    incr i& : textfont(i)=makefont(8,k&,l&,m&,0,"arial")
    incr i& : textfont(i)=makefont(7,k&,l&,m&,0,"courier new")
    incr i& : textfont(i)=makefont(8,k&,l&,m&,0,"times new roman")
    next
    next
    next
    end sub
    ' ------------------------------------------------
    sub getrainbowrgb(byref i&,byref red&,byref green&,byref blue&)
    select case i& 'i& can vary between 0 and 359 (full circle)
    case 0 to 59
    red&=(i& mod 60)*4.25 ' increasing red
    green&=255 ' maximum green
    blue&=0 ' no blue
    case 60 to 119
    red&=255 ' maximum red
    green&=255-(i& mod 60)*4.25 ' decreasing green
    blue&=0 ' no blue
    case 120 to 179
    red&=255 ' maximum red
    green&=0 ' no green
    blue&=(i& mod 60)*4.25 ' increasing blue
    case 180 to 239
    red&=255-(i& mod 60)*4.25 ' decreasing red
    green&=0 ' no green
    blue&= 255 ' maximum blue
    case 240 to 299
    red&=0 ' no red
    green&=(i& mod 60)*4.25 ' increasing green
    blue& = 255 ' maximum blue
    case 300 to 359
    red&=0 ' no red
    green&=255 ' maximum green
    blue&=255-(i& mod 60)*4.25 ' decreasing blue
    case else
    end select
    end sub
    ' ------------------------------------------------
    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
    ' -----------------------
    'type logfont defines the attributes of a font.
    'see logfont in the win32 help file
    hdc = getdc(%hwnd_desktop)
    '
    'retrieves device-specific information about the number
    'of pixels per logical inch along the screen height
    '(depends on screen resolution setting).
    'this is important to define appropriate font sizes.
    logpixelsy = getdevicecaps(hdc, %logpixelsy)
    '
    releasedc %hwnd_desktop, hdc
    '
    lffont.lfheight = -muldiv(fonttypesize,logpixelsy,72) '-(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
    ' -----------------------
    ' make font according to specifications
    function = createfontindirect (lffont)
    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, ymaxscr/ycr!-78, 200, 78, 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
    control send heditform&, %edittext,%em_setsel,0,-1 ' select all text
    control add button, heditform&, %editok, "&ok", 154, 60, 40, 12, _
    %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_editok
    control add button, heditform&, %editcancel, "&cancel", 104, 60, 40, 12, _
    %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_editcancel
    control add label, heditform&, %labelradiobuttonaction, "action after pressing enter or clicking ok:", 8, 28, 160, 10
    control add option, heditform&, %radiobuttonfinishediting, "finish editing", 15, 40, 58, 10, _
    %ws_child or %ws_visible or %bs_autoradiobutton or %ws_group or %ws_tabstop call cbf_radiobuttonfinishedit
    control add option, heditform&, %radiobuttoneditright, "edit cell to the right", 15, 52, 86, 10 call cbf_radiobuttoneditright
    control add option, heditform&, %radiobuttoneditbelow, "edit cell below", 15, 64, 62, 10 call cbf_radiobuttoneditbelow
    control send heditform&,%radiobuttonfinishediting,%bm_setcheck,%bst_checked,0
    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 %vk_return ' 13 ' enter pressed
    call editingoptionsonenterorok
    exit function
    case %vk_escape ' 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
    call editingoptionsonenterorok
    end function
    ' ------------------------------------------------
    sub editingoptionsonenterorok
    local result&,tin&,res2&
    local dif as long
    dim pt as pointapi
    '
    control send heditform&,%radiobuttonfinishediting,%bm_getcheck,0,0 to result&
    if result&=%bst_checked then ' finish editing.
    ' update data array with edited text
    control get text heditform&,%edittext to dataarray(selx,sely)
    dialog end heditform&
    end if
    '
    control send heditform&,%radiobuttoneditright,%bm_

  • #2
    ' DDT Virtual Listview With Row Header, Fonts, Colors and Edit.
    '
    ' Version 2.
    '
    ' This version allows you to specify a font for the column headers.
    ' To do that you must use the handle of the header control build
    ' into the listview control.
    '
    ' The code for dealing with moving of dividers between the headers has
    ' been improved. It is now elicited in the proper way by the relevant
    ' notification message. You are allowed to increase the column width
    ' temporarily, but you cannot make it less than the defined width.
    '
    ' The edit bit has been improving by marking, in the grid, the cell being
    ' edited at any time. In this way you do not loose your orientation. If by
    ' using row or column editing you reach the final row or column, you are
    ' being informed about this by a message box.
    '
    ' Best wishes
    '
    ' Erik Christensen, Copenhagen, Denmark ----- e.chr@email.dk
    '
    ' December 26, 2001: Slight improvements have been made. Two extra empty
    ' columns have been added to allow widening af the last used column.
    '
    ' I tried to maintain varying column widths during horizontal scrolling, but
    ' this markedly reduced scrolling performance. So I decided to re-establish
    ' the preset column widths before horizontal scrolling. However, columns
    ' can maintain a larger width during vertical scrolling. I thank the
    ' PowerBasic forum for the inspiration.
    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
    %EditDescript       = 145
    '
    %EditLabel          = 400
    %EditText           = 410
    %EditOK             = 415
    %EditCancel         = 420
    '
    %LabelRadioButtonAction    = 600
    %RadioButtonFinishEditing  = 605
    %RadioButtonEditRight      = 610
    %RadioButtonEditBelow      = 615
    ' --------------------------------------------------
    DECLARE SUB ShowListDialog(BYVAL hParent&)
    DECLARE CALLBACK FUNCTION CBF_Exit()
    DECLARE CALLBACK FUNCTION ListFrameCallBack()
    DECLARE CALLBACK FUNCTION ListViewWindowCallBack()
    DECLARE SUB UpdateColumnsAndHorzScrollbar (BYVAL xPos AS LONG)
    '
    DECLARE CALLBACK FUNCTION EditDialogProc
    DECLARE CALLBACK FUNCTION CBF_EditText()
    DECLARE CALLBACK FUNCTION CBF_EditOK()
    DECLARE CALLBACK FUNCTION CBF_EditCancel()
    '
    DECLARE CALLBACK FUNCTION CBF_RadioButtonFinishEdit()
    DECLARE CALLBACK FUNCTION CBF_RadioButtonEditRight()
    DECLARE CALLBACK FUNCTION CBF_RadioButtonEditBelow()
    '
    DECLARE 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
    ' --------------------------------------------------
    GLOBAL hListForm&           ' Dialog handle
    GLOBAL hListFrame&          ' Dialog handle
    GLOBAL hListWindow&         ' Dialog handle
    GLOBAL hHeader&             ' Column header handle (within listview)
    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 ColWidth() AS LONG   ' Column width array
    GLOBAL siX AS SCROLLINFO
    GLOBAL gOldSubClassProc&
    GLOBAL gOldSubClassEdit&
    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
    '
    GLOBAL RainBowColors() AS LONG
    GLOBAL TextColor() AS LONG
    GLOBAL TextFont() AS LONG
    GLOBAL EditFlag&
    ' --------------------------------------------------
    '
    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/YCR!
    END FUNCTION
    '
    ' --------------------------------------------------
    FUNCTION PBMAIN
        LOCAL hDC AS LONG
        LOCAL Style&, ExStyle&
        LOCAL X&,Y&,X1&,Y1&,hDlg&
        LOCAL CC1 AS INIT_COMMON_CONTROLSEX
        CC1.dwSize=SIZEOF(CC1)
        CC1.dwICC=%ICC_WIN95_CLASSES
        InitCommonControlsEX CC1
        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
        ' Accomodation of small and big Fonts windows settings
        ' May be improved
        IF XCR!<1.75 THEN YCR!=1.87 ELSE YCR!=1.90
        '
        Style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %WS_MINIMIZEBOX OR %WS_SYSMENU OR %DS_CENTER
        ExStyle& = 0
        ' Create frame window with horizontal scroll bar etc.
        DIALOG NEW 0, "Virtual ListView With Integrated Row Header - Fonts, Colors and Editing", 0, 0,XDU(98),YDU(92), Style&, ExStyle& TO hListFrame&
        CONTROL ADD SCROLLBAR, hListFrame&,%HorzScrollbar,"" ,XDU(20.0),YDU(66.0),XDU(70.62),YDU(3.7), _
            %WS_CHILD OR %WS_VISIBLE OR %SBS_HORZ
        CONTROL ADD BUTTON, hListFrame&,  %ExitButton,  "E&xit",XDU(80),YDU(75),XDU(10),YDU(4.43), _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_Exit
        CONTROL ADD LABEL, hListFrame&, %EditDescript,"Double-click to edit cell", XDU(35),YDU(75),XDU(35),YDU(4.43), _
            %WS_CHILD OR %WS_VISIBLE OR %SS_CENTER
        DIALOG SHOW MODAL hListFrame& CALL ListFrameCallBack
        ' Handle of original frame window is: hListFrame&
    END FUNCTION
    ' --------------------------------------------------
    CALLBACK FUNCTION ListFrameCallBack
        'CBHNDL = hListFrame&
        LOCAL i&,j&
        SELECT CASE CBMSG
            CASE %WM_INITDIALOG
                ' 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)
                ' Two empty columns are being added.
                REDIM DataArray(0:Columns+2,0:Rows+2)' Column zero and row zero are used for headers.
                REDIM ColWidth(0:Columns+2) ' Each column may have it own width if you want that at some time.
                ' Fill array with data
                FOR i&=0 TO Columns
                    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&)= " row"
                            ELSE     '    ' Text of row headers.
                                DataArray(i&,j&)= " row"+STR$(j&)
                            END IF
                        ELSE     ' i& >= 1
                            IF j&=0 THEN  ' Row zero is used for column headers.
                                DataArray(i&,j&)= " column"+STR$(i&)
                            ELSE ' j& >= 1  Item/subitem content
                                DataArray(i&,j&)= " column"+STR$(i&)+" row"+STR$(j&)
                            END IF
                        END IF
                    NEXT
                NEXT
                '
                ' 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 external horizontal scrollbar.
                ' The build-in horizontal scrollbar of listview is not used.
                siX.cbSize = SIZEOF(siX)
                siX.fMask  = %SIF_ALL   ' = %SIF_RANGE OR %SIF_PAGE OR %SIF_POS
                siX.nMin   = 1
                siX.nMax   = Columns + 2 ' Two extra empty columns
                siX.nPage  = PageColumns
                siX.nPos   = 1
                CONTROL SEND CBHNDL, %HorzScrollbar, %SBM_SETSCROLLINFO, %FALSE, VARPTR(siX)
                '
                ' The build-in vertical scrollbar of listview is being used.
                '
                ' Make "viewport" for the listview to be created
                DIALOG NEW CBHNDL, "", XDU(1.8),YDU(2.9),XDU(91.1),YDU(63.5), %WS_CHILD OR %WS_VISIBLE, TO hListWindow&
                ' Make this dialog modeless
                DIALOG SHOW MODELESS hListWindow& CALL ListViewWindowCallBack
                '
                ' Define columns in listview
                CALL DefineColumns(siX.nPos)
                '
                CALL SpecifyDataColorsAndFonts
                '
                ' Get handle for the listview header the simple direct way.
                hHeader& = ListView_GetHeader (hListForm&)
                ' Set column header font
                SendMessage hHeader&,%WM_SETFONT,TextFont(-1),MAKLNG(%TRUE,0)
                '
                SetFocus hListWindow&
                '
                FUNCTION=1: EXIT FUNCTION
            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_THUMBPOSITION ,%SB_THUMBTRACK
                        ' 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))
                CALL UpdateColumnsAndHorzScrollbar(siX.nPos)
                FUNCTION=1: EXIT FUNCTION
        END SELECT
    END FUNCTION
    ' --------------------------------------------------
    CALLBACK FUNCTION ListViewWindowCallBack
        ' Callback Handle CBHNDL is: hListWindow&
        LOCAL rc AS RECT
        LOCAL szString AS ASCIIZ * 256
        LOCAL i&,KK&,Result&,JJ&
        LOCAL HeadNotif AS HD_NOTIFY PTR
        LOCAL my_LpLvNm AS NM_LISTVIEW PTR
        LOCAL pnmh AS NMHDR PTR
        LOCAL lpLVDispInfo AS LV_DISPINFO PTR
        LOCAL lplvcd AS NMLVCUSTOMDRAW PTR
        LOCAL LVRow AS LONG, LVCol AS LONG
        STATIC TimeFlagC AS SINGLE
        LOCAL TimeC AS SINGLE
        SELECT CASE CBMSG
            CASE %WM_INITDIALOG
                '
                GetClientRect CBHNDL, rc
                '
                ' Dimension ColWidths such that the sum of any displayed sets
                ' of columns (including the row header column) is one pixel
                ' larger than the horizontal dimension of the Listview display
                ' minus the vertical scroll bar. This has the effect of having
                ' a hidden internal horizontal listview scroll bar made. This
                ' ensures that the bottom line will not go below the lower edge
                ' of the listview viewport.
                KK&=rc.nRight-rc.nLeft-GetSystemMetrics(%SM_CYVSCROLL)
                JJ&=KK& \(PageColumns+1)
                KK&=KK&-PageColumns*JJ&+1
                FOR i&=0 TO Columns + 2 ' two extra columns can be displayed.
                    IF i&=0 THEN ColWidth(i&)= KK& ELSE ColWidth(i&)=JJ&
                NEXT
                '
                ' ******* This code is due to Semen Matusovski **************
                '
                ' Make Listview control with internal horizontal scroll bar outside the
                ' the edge of the created viewport. This has the effect of
                ' effectively hiding the internal horizontal scroll bar.
                hListForm& = CreateWindowEx(0, "SysListView32", BYVAL 0, _
                   %WS_CHILD OR %WS_VISIBLE OR %LVS_REPORT OR %LVS_AUTOARRANGE OR %LVS_OWNERDATA, 0, 0, _
                   rc.nRight, rc.nBottom + GetSystemMetrics(%SM_CYHSCROLL), _
                   CBHNDL, %ListViewGrid, GetModuleHandle(""), BYVAL 0)
                   ' The %LVS_OWNERDATA style means that ListView will request
                   ' items when needed through %LVN_GETDISPINFO message.
                '
                i = SendMessage (hListForm&, %ListViewGrid, %LVM_GETEXTENDEDLISTVIEWSTYLE, 0)
                i = i OR %LVS_EX_GRIDLINES OR %LVS_EX_FULLROWSELECT
                SendMessage hListForm&, %LVM_SETEXTENDEDLISTVIEWSTYLE, 0, i
                '
                GetClientRect hListForm&, rc
                ' ***********************************************************
                '
                ' Subclass %ListViewGrid
                gOldSubClassProc = SetWindowLong(hListForm&,%GWL_WNDPROC, CODEPTR(SubClassKeys))
                '
            CASE %WM_NOTIFY
                IF LOWRD(CBWPARAM)= %ListViewGrid THEN
                        ' This double click section has been inspired by the
                        ' code by David L Morris.
                        my_LpLvNm = CBLPARAM
                        SELECT CASE @my_LpLvNm.hdr.code
                            CASE %NM_DBLCLK
                            'CASE %NM_CLICK ' You can use single click instead if you wnat
                                'cursor position
                                LVRow = @my_LpLvNm.iItem
                                LVCol = @my_LpLvNm.iSubItem
                                ' Get array indices corresponding to selected cell
                                SelX = siX.nPos + LVCol - 1 ' adjust for presence of "internal" row header
                                SelY = LVRow + 1
                                IF LVCol>0 AND SelX<=Columns THEN EditFlag=1 : CALL EditCellForm(hListForm&) ' Edit cell - new text to data array
                                EditFlag&=EditFlag&+2
                                SetFocus hListForm&
                                InvalidateRect hListForm&,BYVAL %NULL,%FALSE
                                IF EditFlag&=4 THEN MSGBOX "You reached the last column.",%MB_ICONSTOP,"Editing stopped."
                                IF EditFlag&=5 THEN MSGBOX "You reached the last row.",%MB_ICONSTOP,"Editing stopped."
                                EditFlag=0
                                FUNCTION = 1
                                EXIT FUNCTION
                            CASE %NM_CUSTOMDRAW
                                ' This section is inspired by feedback from
                                ' Semen Matusovski, David Kenny and Lance Edmonds
                                lplvcd = CBLPARAM
                                IF(@lplvcd.nmcd.dwDrawStage = %CDDS_PREPAINT) THEN
                                    ' The following statement ensures that the relevant
                                    ' messages are coming back to Windows, so Windows
                                    ' can respond appropriately. This method may be useful
                                    ' in many other situations where the DDT engine may
                                    ' swallow the information.
                                    ' 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 = 0 THEN             ' Row header
                                        ' Specify background color
                                        @lplvcd.clrTextBk = RGB(227,227,227) ' light gray
                                        ' Specify text color
                                        @lplvcd.clrText = RGB(0,0,0)         ' black
                                        ' Specify font
                                        SelectObject @lplvcd.nmcd.hdc, TextFont(-1)
                                    ELSE                                     ' Column 1 and beyond
                                        KK& = @lplvcd.nmcd.dwItemSpec + @lplvcd.iSubItem + siX.nPos
                                        IF EditFlag&<>1 THEN ' No cell is being edited.
                                             ' Specify background color
                                            @lplvcd.clrTextBk = RainBowColors(KK& MOD 72)
                                             ' Specify text color
                                            @lplvcd.clrText = TextColor(KK& MOD 72)
                                        ELSE ' A cell is being edited.
                                             ' Is the currently drawn cell that being edited?
                                            IF (@lplvcd.nmcd.dwItemSpec + 1 = SelY) AND (@lplvcd.iSubItem + siX.nPos - 1 = SelX) THEN
                                                 ' Yes. Then make it gray with white text.
                                                @lplvcd.clrTextBk = RGB(120,120,120)
                                                @lplvcd.clrText = RGB(255,255,255)
                                            ELSE ' No. Then give it the usual colors.
                                                @lplvcd.clrTextBk = RainBowColors(KK& MOD 72)
                                                @lplvcd.clrText = TextColor(KK& MOD 72)
                                            END IF
                                        END IF
                                        ' Specify font
                                        SelectObject @lplvcd.nmcd.hdc, TextFont(KK& MOD 29)
                                    END IF
                                    SetWindowLong hListWindow&,%DWL_MSGRESULT,(%CDRF_NEWFONT)' OR %CDRF_NOTIFYSUBITEMDRAW)
                                    FUNCTION = 1: EXIT FUNCTION
                                END IF
                            CASE %LVN_GETDISPINFO    'Virtual ListView ask for Item text
                                lpLVDispInfo = CBLPARAM
                                IF (@lpLVDispInfo.item.mask AND %LVIF_TEXT) THEN
                                    ' Specify text to be used
                                    IF @lpLVDispInfo.item.iSubItem = 0 THEN ' row header
                                        szString = DataArray(0 , @lpLVDispInfo.item.iItem + 1)
                                    ELSE                                    ' column 1 and beyond
                                        szString = DataArray(@lpLVDispInfo.item.iSubItem + siX.nPos - 1 , @lpLVDispInfo.item.iItem + 1)
                                    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
                        ' Prevent column width to be less than the original setting.
                        ' This arrangement means the following few lines are
                        ' executed only at 0.6 seconds interval at the most.
                        TimeC=TIMER
                        IF TimeC-TimeFlagC > 0.6 THEN
                            Result&=SendMessage(hListForm&,%LVM_GETCOLUMNWIDTH, 0, 0)
                            IF Result&<ColWidth(0) THEN
                                SendMessage hListForm&,%LVM_SETCOLUMNWIDTH, 0, MAKLNG(ColWidth(0), 0) ' Row header
                                InvalidateRect hListForm&,BYVAL %NULL,%FALSE
                            ELSE
                                FOR KK& = siX.nPos TO siX.nPos+PageColumns-1
                                    Result&=SendMessage(hListForm&,%LVM_GETCOLUMNWIDTH,KK&-siX.nPos+1, 0)
                                    IF Result&<ColWidth(KK&) THEN
                                        SendMessage hListForm&,%LVM_SETCOLUMNWIDTH,KK&-siX.nPos+1, MAKLNG(ColWidth(KK&), 0)
                                        InvalidateRect hListForm&,BYVAL %NULL,%FALSE
                                    END IF
                                NEXT
                            END IF
                            TimeFlagC = TIMER
                        END IF
                    END IF
                END IF
            CASE %WM_DESTROY
                FOR i=-1 TO 28  ' Delete fonts that have been made.
                    CALL DeleteObject (TextFont(i&))
                NEXT
                ' 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.
        ' 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
                SELECT CASE CBWPARAM
                    CASE %VK_LEFT  : DECR siX.nPos
                    CASE %VK_RIGHT : INCR siX.nPos
                    CASE %VK_HOME  : siX.nPos = 0
                    CASE %VK_END   : siX.nPos = Columns+2
                    CASE ELSE : EXIT SELECT
                END SELECT
                ' Ensure that positions are within range
                siX.nPos = MAX&(siX.nMin, MIN&(siX.nPos, siX.nMax - siX.nPage + 1))
                CALL UpdateColumnsAndHorzScrollbar(siX.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 SetColumnText(BYVAL ColPos AS LONG,BYVAL ArrayPos AS LONG,BYVAL txt AS STRING)
        LOCAL zText AS ASCIIZ * 100
        LOCAL lvc AS LV_COLUMN
        lvc.mask = %LVCF_TEXT OR %LVCF_WIDTH 'OR %LVCF_SUBITEM OR %LVCF_FMT
        ' Get relevant data about column structure
        SendMessage hListForm&, %LVM_GETCOLUMN, ColPos, VARPTR(lvc)
        lvc.cx = ColWidth(ArrayPos) ' make sure to maintain original column width
        zText = txt
        lvc.pszText = VARPTR(zText)
        ' Send new text to column
        SendMessage hListForm&,%LVM_SETCOLUMN, ColPos, VARPTR(lvc)
    END SUB
    ' ------------------------------------------------
    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 column headers
        FOR KK& = xPos TO xPos+PageColumns ' includes row header column
            lvc.cx = ColWidth(KK&-1)
            ' column header text
            lvc.fmt = %LVCFMT_LEFT ' set justification
            zText = DataArray(KK&-1,0)
            LVC.pszText = VARPTR(zText)
            SendMessage hListForm&,%LVM_INSERTCOLUMN, KK&, VARPTR(lvc)
        NEXT
        '
        ' Dimension the listview in regard to total number of rows.
        ' This includes dimensioning of the internal vertical scroll bar
        ' of listview which we use. Thus no external vertical
        ' scroll bar is necessary in this program.
        ListView_SetItemCountEx hListForm&,Rows,%LVSICF_NOINVALIDATEALL
    END SUB
    ' ------------------------------------------------
    SUB UpdateColumnsAndHorzScrollbar(BYVAL xPos AS LONG)
        LOCAL KK&
        STATIC xPrevPos AS LONG  ' previous x-position (remember between calls)
        SetFocus hListForm&
        '
        IF xPos<>xPrevPos THEN ' Moved in X-direction (horizontal)
            ' Update horizontal scroll bar
            siX.fMask = %SIF_POS
            CONTROL SEND hListFrame& , %HorzScrollbar, %SBM_SETSCROLLINFO, %TRUE, VARPTR(siX)
            ' Set row header coloumn width to ensure it is kept constant
            SendMessage hListForm&,%LVM_SETCOLUMNWIDTH, 0, MAKLNG(ColWidth(0), 0)
            ' Update column headers
            FOR KK& = xPos TO xPos+PageColumns-1
                CALL SetColumnText(KK&-xPos+1,KK&,DataArray(KK&,0))
            NEXT
            ' Force updating of listview to be made
            InvalidateRect hListForm&,BYVAL %NULL,%FALSE
        END IF
        xPrevPos=xPos ' Remember new previous x-position
    END SUB
    ' ------------------------------------------------
    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
    ' --------------------------------------------------------------
    SUB SpecifyDataColorsAndFonts
        LOCAL i&,j&, Red&, Green&, Blue&,KK&,II&,k&,l&,m&,JJ&
        REDIM RainBowColors(0:71)
        REDIM TextColor(0:71)
        REDIM TextFont (-1:28)
        FOR i&=0 TO 359 STEP 5          ' one 360 degrees turn (color loop)
            CALL GetRainbowRGB(BYREF i&,BYREF Red&,BYREF Green&,BYREF Blue&)
            RainBowColors(i/5)=RGB(Red&,Green&,Blue&)
            ' Decide from color if text should be black or white
            ' This function is suited when transformation to a grey scale is needed.
            IF Red&*.222+Green&*.707+Blue&*.071>128 THEN  ' Color is light,
                TextColor(i/5)=RGB(0,0,0)                 ' then text should be black.
            ELSE                                          ' Color is dark,
                TextColor(i/5)=RGB(255,255,255)           ' then text should be white.
            END IF
        NEXT
        i&=-1   : TextFont(i)=MakeFont(9,700,0,0,0,"Klang MT")
        INCR i& : TextFont(i)=MakeFont(8,700,0,0,0,"Papyrus")
        INCR i& : TextFont(i)=MakeFont(8,600,0,0,0,"Tempus Sans ITC")
        INCR i& : TextFont(i)=MakeFont(9,400,0,0,0,"Klang MT")
        INCR i& : TextFont(i)=MakeFont(9,400,0,0,0,"Eras Medium ITC")
        INCR i& : TextFont(i)=MakeFont(11,400,0,0,0,"Edwardian Script ITC")
        FOR k&=400 TO 700 STEP 300  ' Font Weight loop - normal or bold
            FOR l&=0 TO 1           ' Italic loop - normal or italic
                FOR m&=0 TO 1       ' Underline loop - normal or underline
                    INCR i& : TextFont(i)=MakeFont(8,k&,l&,m&,0,"Arial")
                    INCR i& : TextFont(i)=MakeFont(7,k&,l&,m&,0,"Courier New")
                    INCR i& : TextFont(i)=MakeFont(8,k&,l&,m&,0,"Times New Roman")
                NEXT
            NEXT
        NEXT
    END SUB
    ' ------------------------------------------------
    SUB GetRainbowRGB(BYREF i&,BYREF Red&,BYREF Green&,BYREF Blue&)
        SELECT CASE i& 'i& can vary between 0 and 359 (full circle)
            CASE 0 TO 59
                Red&=(i& MOD 60)*4.25       ' increasing red
                Green&=255                  ' maximum green
                Blue&=0                     ' no blue
            CASE 60 TO 119
                Red&=255                    ' maximum red
                Green&=255-(i& MOD 60)*4.25 ' decreasing green
                Blue&=0                     ' no blue
            CASE 120 TO 179
                Red&=255                    ' maximum red
                Green&=0                    ' no green
                Blue&=(i& MOD 60)*4.25      ' increasing blue
            CASE 180 TO 239
                Red&=255-(i& MOD 60)*4.25   ' decreasing red
                Green&=0                    ' no green
                Blue&= 255                  ' maximum blue
            CASE 240 TO 299
                Red&=0                      ' no red
                Green&=(i& MOD 60)*4.25     ' increasing green
                Blue& = 255                 ' maximum blue
            CASE 300 TO 359
                Red&=0                      ' no red
                Green&=255                  ' maximum green
                Blue&=255-(i& MOD 60)*4.25  ' decreasing blue
            CASE ELSE
        END SELECT
    END SUB
    ' ------------------------------------------------
    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
    ' -----------------------
        'TYPE LOGFONT defines the attributes of a font.
        'See LOGFONT in the Win32 help file
        hDC = GetDC(%HWND_DESKTOP)
        '
        'Retrieves device-specific information about the number
        'of pixels per logical inch along the screen height
        '(depends on screen resolution setting).
        'This is important to define appropriate font sizes.
        LogPixelsY  = GetDeviceCaps(hDC, %LOGPIXELSY)
        '
        ReleaseDC %HWND_DESKTOP, hDC
        '
        lfFont.lfHeight = -MulDiv(FontTypeSize,LogPixelsY,72) '-(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
    ' -----------------------
        ' Make font according to specifications
        FUNCTION = CreateFontIndirect (lfFont)
    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, YMaxScr/YCR!-78,  200,  78, 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
        CONTROL SEND hEditForm&, %EditText,%EM_SETSEL,0,-1  ' select all text
        CONTROL ADD BUTTON, hEditForm&,  %EditOK,  "&OK", 154, 60, 40, 12, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_EditOK
        CONTROL ADD BUTTON, hEditForm&,  %EditCancel,  "&Cancel", 104, 60, 40, 12, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_EditCancel
        CONTROL ADD LABEL, hEditForm&,  %LabelRadioButtonAction,  "Action After Pressing ENTER or Clicking OK:", 8, 28, 160, 10
        CONTROL ADD OPTION, hEditForm&,  %RadioButtonFinishEditing,  "Finish Editing", 15, 40, 58, 10, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_AUTORADIOBUTTON OR %WS_GROUP OR %WS_TABSTOP CALL CBF_RadioButtonFinishEdit
        CONTROL ADD OPTION, hEditForm&,  %RadioButtonEditRight,  "Edit Cell to the Right", 15, 52, 86, 10 CALL CBF_RadioButtonEditRight
        CONTROL ADD OPTION, hEditForm&,  %RadioButtonEditBelow,  "Edit Cell Below", 15, 64, 62, 10 CALL CBF_RadioButtonEditBelow
        CONTROL SEND hEditForm&,%RadioButtonFinishEditing,%BM_SETCHECK,%BST_CHECKED,0
        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 %VK_RETURN ' 13 ' ENTER pressed
                        CALL EditingOptionsOnENTERorOK
                        EXIT FUNCTION
                    CASE %VK_ESCAPE ' 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
        CALL EditingOptionsOnENTERorOK
    END FUNCTION
    ' ------------------------------------------------
    SUB EditingOptionsOnENTERorOK
        LOCAL result&,Tin&,res2&
        LOCAL Dif AS LONG, RenewFlag&
        DIM pt AS POINTAPI
        '
        CONTROL SEND hEditForm&,%RadioButtonFinishEditing,%BM_GETCHECK,0,0 TO result&
        IF result&=%BST_CHECKED THEN ' Finish editing.
            ' update data array with edited text
            CONTROL GET TEXT hEditForm&,%EditText TO DataArray(SelX,SelY)
            DIALOG END hEditForm&
        END IF
        '
        CONTROL SEND hEditForm&,%RadioButtonEditRight,%BM_GETCHECK,0,0 TO result&
        IF result&=%BST_CHECKED THEN ' Edit cell to the right.
            ' update data array with previously edited text
            CONTROL GET TEXT hEditForm&,%EditText TO DataArray(SelX,SelY)
            '
            IF SelX>=Columns THEN ' last cell in row - finish editing
                BEEP : EditFlag&=2 : DIALOG END hEditForm&
            ELSE
                ' Move to the right
                INCR SelX : IF SelX > siX.nPos + PageColumns -1 THEN INCR siX.nPos
                siX.nPos = MAX&(siX.nMin, MIN&(siX.nPos, siX.nMax - siX.nPage + 1))
            END IF
            CONTROL SET TEXT hEditForm&,%EditLabel,"Column"+STR$(SelX)+"  Row"+STR$(SelY)
            CONTROL SET TEXT hEditForm&,%EditText, DataArray(SelX,SelY)
            CONTROL SEND hEditForm&, %EditText,%EM_SETSEL,0,-1  ' select all text
            CONTROL SET FOCUS hEditForm&,%EditText
        END IF
        '
        CONTROL SEND hEditForm&,%RadioButtonEditBelow,%BM_GETCHECK,0,0 TO result&
        IF result&=%BST_CHECKED THEN ' Edit cell below.
            ' update data array with previously edited text
            CONTROL GET TEXT hEditForm&,%EditText TO DataArray(SelX,SelY)
            IF SelY>=Rows THEN ' last cell in column - finish editing
                BEEP : EditFlag&=3 : DIALOG END hEditForm&
            ELSE
                ' Move down
                INCR SelY
                Tin&=ListView_GetTopIndex(hListForm&)
                res2& = SendMessage(hListForm&, %LVM_GETITEMPOSITION,Tin&, VARPTR(pt))
                Dif = pt.y
                res2& = SendMessage(hListForm&, %LVM_GETITEMPOSITION,Tin&+1, VARPTR(pt))
                Dif = pt.y - Dif ' Vertical pixels of one line of listview.
                IF SelY-Tin&>PageRows THEN ' Scroll listview one line down.
                    Tin&=ListView_Scroll(hListForm&,0,Dif)
                END IF
            END IF
            CONTROL SET TEXT hEditForm&,%EditLabel,"Column"+STR$(SelX)+"  Row"+STR$(SelY)
            CONTROL SET TEXT hEditForm&,%EditText, DataArray(SelX,SelY)
            CONTROL SEND hEditForm&, %EditText,%EM_SETSEL,0,-1  ' select all text
            CONTROL SET FOCUS hEditForm&,%EditText
        END IF
        CALL UpdateColumnsAndHorzScrollbar(siX.nPos)
        ' Force updating of listview to be made
        InvalidateRect hListForm&,BYVAL %NULL,%FALSE
    END SUB
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_EditCancel
        DIALOG END hEditForm&
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_RadioButtonFinishEdit
        CONTROL SET FOCUS hEditForm&,%EditText
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_RadioButtonEditRight
        CONTROL SET FOCUS hEditForm&,%EditText
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_RadioButtonEditBelow
        CONTROL SET FOCUS hEditForm&,%EditText
    END FUNCTION
    ' ------------------------------------------------


    [This message has been edited by Erik Christensen (edited December 26, 2001).]

    Comment

    Working...
    X