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

Fast Prioritized Index Sorting Demonstration Program

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

  • Fast Prioritized Index Sorting Demonstration Program

    ' fast prioritized index sorting demonstration program
    '
    ' this is a simplified and improved version of this program:
    http://www.powerbasic.com/support/pb...ad.php?t=23789

    ' it uses this simple virtual listview with row-header:
    http://www.powerbasic.com/support/pb...ad.php?t=24760

    ' it includes this routine for accurate time interval measurements:
    http://www.powerbasic.com/support/pb...ad.php?t=24258

    ' it also includes routines for reading and saving data in tab-separated
    ' ascii format.
    '
    ' best regards
    '
    ' erik christensen --------- march 5, 2006
    '
    ' p.s. march 6, 2006: small changes to allow the program to run under pbwin 7.0
    ' if you are having difficulties in having the program running, you can change
    ' the number of rows to a lesser number in sub generatedefaultdata.
    [CODE]
    #compile exe
    #register none
    #dim all
    '
    #include "win32api.inc"
    #include "commctrl.inc"
    #include "comdlg32.inc"
    '
    %idc_label101 = 101
    %idc_label102 = 102
    %idc_label103 = 103
    %idc_label104 = 104
    %idc_label105 = 105
    %idc_label140 = 140
    %idc_label125 = 125
    %idc_label135 = 135
    %idc_label145 = 145
    %idc_label150 = 150
    %idc_combobox11 = 11
    %idc_combobox12 = 12
    %idc_combobox13 = 13
    %idc_combobox14 = 14
    %idc_combobox15 = 15
    %idc_combobox21 = 21
    %idc_combobox22 = 22
    %idc_combobox23 = 23
    %idc_combobox24 = 24
    %idc_combobox25 = 25
    %idc_combobox31 = 31
    %idc_combobox32 = 32
    %idc_combobox33 = 33
    %idc_combobox34 = 34
    %idc_combobox35 = 35
    %idc_listview400 = 400
    %idc_listview410 = 410
    %idc_button420 = 420
    %idc_button430 = 430
    %idc_button440 = 440
    '----------------------------------------------------------------------
    %noanimate = 1 ' animate control
    %nobutton = 1 ' button
    %nocombo = 1 ' combo box
    %nocomboex = 1 ' comboboxex
    %nodatetimepick = 1 ' date/time picker
    %nodraglist = 1 ' drag list control
    %noedit = 1 ' edit control
    %noflatsbapis = 1 ' flat scroll bar
    %noheader = 1 ' header control
    %nohotkey = 1 ' hotkey control
    %noimagelist = 1 ' image apis
    %noipaddress = 1 ' ip address edit control
    %nolist = 1 ' list box control
    '%nolistview = 1 ' listview control
    %nomenuhelp = 1 ' menu help
    %nomonthcal = 1 ' monthcal
    %nomui = 1 ' mui
    %nonativefontctl = 1 ' native font control
    %nopagescroller = 1 ' pager
    %noprogress = 1 ' progress control
    %norebar = 1 ' rebar control
    %nostatusbar = 1 ' status bar
    %notabcontrol = 1 ' tab control
    %notoolbar = 1 ' tool bar
    %notooltips = 1 ' tool tips
    %notrackbar = 1 ' track bar
    %notrackmouseevent = 1 ' track mouse event
    %notreeview = 1 ' treeview
    %noupdown = 1 ' up down arrow control
    '
    function currenttimepointinseconds as double
    ' this function returns the number of seconds since midnight
    ' as a double-precision floating-point value.
    static perffreq as quad, res as long, prec as long, first as long, timecorrection as double
    local t1 as quad, ta as double
    '
    if isfalse first then
    ' get, in counts per second, the current performance-counter frequency
    ' if supported by your hardware.
    res = queryperformancefrequency(perffreq)
    '
    ' determine precision
    if res then
    prec = ceil(log10(perffreq))
    queryperformancecounter t1
    ta = round(cdbl(t1) / cdbl(perffreq), prec)
    ' find time correction to obtain number of seconds past midnight.
    timecorrection = timer - ta
    '
    function = ta + timecorrection
    first = %true : exit function
    else
    prec = 2 ' precision of timer is only about 1/18th of a second.
    end if
    first = %true
    end if
    ' measure current time
    if res then ' if possible use this:
    queryperformancecounter t1
    function = round(cdbl(t1) / cdbl(perffreq), prec) + timecorrection
    else ' else use the built-in timer
    ta = timer
    function = round(ta, prec)
    end if
    '
    end function
    '
    sub about
    local t as string
    t="prioritized index sorting"+$crlf+$crlf _
    +"coded by:"+$crlf+$crlf _
    +"erik christensen"+$crlf+$crlf _
    +"march 5th, 2006"
    msgbox t, %mb_iconinformation, "about this program"
    end sub
    '
    sub explain
    local t as string
    t="the advantage of index sorting is that the data being sorted need not " _
    +"be moved within the data-array. this is in contrast " _
    +"to ordinary sorting in which the original position of items is irretrievably lost."+$crlf+$crlf _
    +"an index array is formed which holds the sequence of the data after " _
    +"sorting. for example, after ascending sorting the 3rd smallest value " _
    +"will be dataarray(index(3)). after ordinary sorting it would just have " _
    +"been dataarray(3). "+$crlf+$crlf _
    +"the routine presented is simple and versatile: it can sort ascending, " _
    +"descending, numerical and alphabetical according to your wish. in addition, it can " _
    +"perform prioritized sorting. "+$crlf+$crlf _
    +"prioritized sorting is relevant if many items are the same for a " _
    +"variable e.g. family name, since within each of these you can sort " _
    +"according to a secondary variable like first name. if you still " _
    +"have many persons with the same family name and first name, you can " _
    +"within each of these combinations sort according to a third variable " _
    +"like age and so on. in principle you can perform prioritized sorting " _
    +"according to all the variables in the dataset. "+$crlf+$crlf _
    +"this program presents an effective and fast routine for prioritized " _
    +"index sorting for up to 5 variables at a time." _
    +"you can use the built-in default database or you can load a database in " _
    +"tab-separated ascii format. by default the first line should hold the " _
    +"variable names, which would then become the column headings." _
    +"in the left combo boxes you select the variable(s) by which the data should " _
    +"be sorted. in the center combo boxes you specify if sorting should be ascending or " _
    +"descending for the variable in question. in the right combo boxes you specify if " _
    +"sorting should be numerical or alphabetical. the program " _
    +"automatically suggests one of the two possibilities based on the characters in the variable. " _
    +"start sorting by clicking the sort-button. " _
    +"you can always retrieve the original order of the data by clicking that particular button. " _
    +"you can save the data in the displayed order (sorted or unsorted) to a tab-separated ascii file, " _
    +"which can be imported in other programs like excel. "+$crlf+$crlf _
    +"good luck and best regards march 5, 2006"+$crlf+$crlf _
    +" erik"
    msgbox t, %mb_iconinformation,"information and help: fast prioritized index sorting"
    end sub
    '
    sub posisort (byref a() as string ,byref indx() as long, byval columns as long, byval rows as long, byref prio() as long)
    ' this is a modification of a pointer sort routine
    ' published by hewlett packard in the hp basic program library
    ' handbook many years ago.
    ' the pointer chain is being replaced by an index showing
    ' the place where the row should be when the
    ' data are being displayed after sorting.
    ' code for ascending and descending sorting has been added.
    ' code for string and numerical sorting has also been added.
    local rowindex as long, b as long, g as long, d as long, e as long, f as long, de as long, j as long, x as long, fl as long, i as long, k as long, m as long, n as long, dept as long
    dept = ceil(log2(cext(rows)))
    dim depth(dept) as local long
    dim chain(rows) as local long
    k=0
    do
    incr k
    if k=columns then exit do
    if prio(0,k+1)=0 then exit do
    loop
    '
    fl=0
    for rowindex = 1 to rows
    b = rowindex
    chain(rowindex) = rowindex
    for de = 1 to dept
    g = depth(de)
    if g = 0 then
    if rowindex = rows then goto hoptonext
    depth(de) = b
    fl=1
    exit for
    end if
    fl=0
    d = b: e = b: f = b

    doagain :
    for j=1 to k
    m=prio(0,j): n=prio(1,j)
    if prio(2,j)=1 then ' ascending
    if n=0 then ' string
    if a(m,d) < a(m,g) then goto goingdown
    if a(m,d) > a(m,g) then goto goingup
    else ' numerical
    if val(a(m,d)) < val(a(m,g)) then goto goingdown
    if val(a(m,d)) > val(a(m,g)) then goto goingup
    end if
    else ' descending
    if n=0 then ' string
    if a(m,d) > a(m,g) then goto goingdown
    if a(m,d) < a(m,g) then goto goingup
    else ' numerical
    if val(a(m,d)) > val(a(m,g)) then goto goingdown
    if val(a(m,d)) < val(a(m,g)) then goto goingup
    end if
    end if
    next
    '
    if e < 0 then goto goingdown
    '
    goingup:
    e = -e
    if d = f then
    b = g
    else
    chain(f) = g
    f = d
    end if
    '
    d = g
    g = f
    '
    goingdown:
    f = d
    d = chain(d)
    if d <> f then goto doagain
    chain(f) = g
    depth(de) = 0
    '
    hoptonext:
    next
    if fl=0 then exit for ' finished
    fl=0
    next
    ' the chain pointer is now being replaced by an index.
    j = b ' = the place of the first value in the chain
    ' which points to the next and so on.
    indx(1) = b
    for x = 2 to rows
    j = chain(j)
    indx(x) = j
    next
    erase chain
    end sub
    '
    function samplelistview(byval hdlg as dword, byval lid as long, byval lcolcnt _
    as long, byval lrowcnt as long, byref maxlen() as long, byref alphnum() as long, byref head() as string) as long
    local lcol as long
    local lrow as long
    local hctl as dword
    local tlvc as lv_column
    local tlvi as lv_item
    local szbuf as asciiz * 32
    local lstyle as long
    control handle hdlg, lid to hctl
    listview_deleteallitems hctl
    for lcol = 0 to lcolcnt-1
    sendmessage hctl,%lvm_deletecolumn, 0, 0
    next
    lstyle = listview_getextendedlistviewstyle(hctl)
    listview_setextendedlistviewstyle(hctl, lstyle _
    or %lvs_ex_gridlines)
    ' load column headers.
    tlvc.mask = %lvcf_fmt or %lvcf_text or %lvcf_subitem
    tlvc.psztext = varptr(szbuf)
    for lcol = 0 to lcolcnt-1
    if alphnum(lcol+1) = 0 then tlvc.fmt = %lvcfmt_left else tlvc.fmt = %lvcfmt_right
    szbuf = head(lcol+1)
    tlvc.iorder = lcol
    listview_insertcolumn(hctl, lcol, tlvc)
    next lcol
    ' size columns.
    for lcol = 0 to lcolcnt - 1
    sendmessage(hctl, %lvm_setcolumnwidth, lcol, maklng(maxlen(lcol+1), 0))
    next lcol
    listview_setitemcountex hctl, lrowcnt, %lvsicf_noinvalidateall
    end function
    '
    sub displaydata((byval columns as long, byval rows as long, byref head() as string, _
    byref dataarray() as string, byval hdlg as long, byref alphnum() as long, byref maxlen() as long)
    local i&,res&
    dim ml(1 to 1) as local long, an(1 to 1) as local long, h(1 to 1) as string
    dialog units hdlg, 37, 5 to pixels ml(1), i
    h(1) = "item"
    an(1) = 0 : ml(1) = ml(1) - getsystemmetrics(%sm_cxvscroll) + 1
    res = samplelistview(hdlg, %idc_listview400, columns, rows, maxlen(), alphnum(), head())
    res = samplelistview(hdlg, %idc_listview410, 1, rows, ml(), an(), h())
    for i = 11 to 15 : control send hdlg, i, %cb_resetcontent, 0, 0 : next
    for i=0 to columns-1
    if columns>=1 then combobox add hdlg, %idc_combobox11, head(i+1)
    next
    end sub
    '
    sub checkdata((byval columns as long, byval rows as long, byref head() as string, _
    byref dataarray() as string, byval hdlg as long, byref alphnum() as long, byref maxlen() as long, byref indx() as long)
    local b$,i&,j&,k&,x&,m&,n&,hctl&,alflag&,d$,l&,res&
    local st as asciiz * 250
    ' find maximum string length for each column.
    ' classify column as alphabetic or numerical.
    redim alphnum(1 to columns), maxlen(1 to columns)
    redim indx(1 to rows)

    for i = 1 to rows : indx(i) = i : next

    for i&=1 to columns
    st = head(i)
    control send hdlg, %idc_listview400, %lvm_getstringwidth, 0, varptr(st) to k
    maxlen(i) = max(maxlen(i), k + 20)
    alphnum(i)=1 ' presume numerical for a start
    alflag&=1
    for j&=1 to min(rows,100)
    st = dataarray(i,j)
    control send hdlg, %idc_listview400, %lvm_getstringwidth, 0, varptr(st) to k
    maxlen(i) = max(maxlen(i), k + 20) ' get max string length of variable
    if alflag=1 then
    if istrue verify(st, "0123456789.,+-ed") then alphnum(i)=0 : alflag&=0 ' alphabetical
    end if
    next
    next
    end sub
    '
    sub generatedefaultdata(byref columns as long, byref rows as long, byref head() as string, _
    byref dataarray() as string, byval hdlg as long)
    mouseptr 11
    local i&
    ' make default test data set.
    data "surname","first name","city","age (years)","weight (kg)","height (cm)","body mass index (bmi) (kg/m²)"
    data "andersen","jones","smith","evans","nielsen","petersen"
    data "holmes","burton","monroe","watson","goethe","hals"
    data "schiller","rembrandt","bonaparte","wells","verne","shakespeare"
    data "hans","peter","eric","alan","alain","jean"
    data "john","william","claude","michael","carl","james"
    data "eve","marilyn","claudia","maria","susan","karin"
    data "los angeles","new york","washington","san diego","san francisco","chicago"
    data "paris","london","berlin","copenhagen","oslo","stockholm"
    data "amsterdam","brussels","moscow","saint petersburg","shanghai","tokyo"
    '
    columns = 7 ' number of columns
    '****************************************************************
    ' nb: you can reduce the number of rows to a lesser number, e.g. 1000 if you have problems in having the program running.
    rows = 100000 ' number of rows
    '****************************************************************
    '
    redim head(1 to columns), dataarray(1 to columns, 1 to rows)
    for i&=1 to columns : head(i&)=read$(i&) : next
    randomize 1.634 ' ensures same data set each time you selects default data
    for i&=1 to rows
    dataarray(1,i&)=read$(rnd(8,25))
    dataarray(2,i&)=read$(rnd(26,43))
    dataarray(3,i&)=read$(rnd(44,61))
    dataarray(4,i&)=ltrim$(str$(rnd(10,100)))
    dataarray(5,i&)=ltrim$(str$(rnd(50,130)))
    dataarray(6,i&)=ltrim$(str$(rnd(160,210)))
    dataarray(7,i&)=ltrim$(str$(round(val(dataarray(5,i&))*10000/val(dataarray(6,i&))^2,1)))
    next
    mouseptr 1
    end sub
    '
    function filnamesave(byref pafuout as string, byref pafu as string, byval delim as string, _
    byval columns as long, byval rows as long, byref head() as string, byref dataarray() as string, byref indx() as long) as long
    local path as string
    local f as string
    local lstyle as dword
    local hfile as long
    local i&,j&,res&
    igen:
    pafuout="
    path=left$(pafu, instr(-1, pafu, any "/:\")) 'filepath(pafu)
    f="
    lstyle = %ofn_hidereadonly or %ofn_longnames
    if savefiledialog(0, "save file", f, path, _
    "text files|*.txt|all files|*.*", "txt", lstyle) then

    pafuout=f
    if pafu=pafuout then
    res& = msgbox ("output file name the same as input file name. do you want this ?",%mb_iconhand or %mb_yesno, "problem:")
    if res&=%idno then goto igen
    end if
    hfile = freefile

    open pafuout for output as hfile

    delim = $tab ' saves in tab-delimited text format.
    ' this format can be imported in most
    ' spreadsheet and data base programs
    ' like excel and access.
    mouseptr 11
    ' first save the column header line
    for i&=1 to columns
    print# hfile, head(i&);

    ' put delimiter after each column header
    ' except the last
    if i&<columns then print# hfile,delim;
    next
    print# hfile, $crlf; ' start a new line

    ' then save the data - one row at a time
    for j&=1 to rows
    for i&=1 to columns
    print# hfile, dataarray(i&,indx(j&));
    ' put delimiter after each field
    ' except the last
    if i&<columns then print# hfile,delim;
    next
    if j<rows then print# hfile, $crlf; ' start a new line
    next

    close hfile
    function = 1
    end if
    mouseptr 1
    end function
    '
    function filnameopen(byref pafuout as string, byref pafu as string, byval delim as string, _
    byref columns as long, byref rows as long, byref head() as string, byref dataarray() as string, _
    byref indx() as long, byval hdlg as long) as long
    local path as string
    local f as string
    local lstyle as dword
    local hfile as long
    local i&,j&
    local ecode as long, filestring as string, st as string
    dim temp() as local string
    path = curdir$

    igen:
    f = "*.txt"
    lstyle = %ofn_filemustexist or %ofn_hidereadonly or %ofn_longnames
    if openfiledialog(0, "open file", f, path, _
    "text files|*.txt|all files|*.*", "txt", lstyle) then
    pafu=f
    rows = 0
    hfile = freefile
    on error resume next
    mouseptr 11
    open pafu for binary as #hfile
    ecode = errclear : if ecode then msgbox "error on file, code=" & str$(ecode) : goto exit1
    get$ #hfile, lof(hfile), filestring$
    ecode = errclear : if ecode then msgbox "error on file, code=" & str$(ecode) : close #hfile: goto exit1
    close #hfile
    rows = parsecount(filestring$, $crlf) - 1
    'msgbox str$(rows)
    redim temp(0 to rows)
    parse filestring$, temp(), $crlf
    st = temp(0)
    ' delimiter:
    delim = $tab
    ' tab (chr$(9)) delimited text data without quotes are
    ' assumed in this version.
    ' most spreadsheet and data base programs can export data
    ' in tab-separated text format to be read by this program.
    ' if you so wish you can also use other delimiters, such
    ' as comma, semicolon etc.
    columns = parsecount(st, delim)
    redim dataarray(1 to columns, 1 to rows)
    redim head(1 to columns)
    dim temp1(1 to columns) as local string
    parse st, head(), delim
    for i = 1 to rows
    st = temp(i)
    if parsecount(st, delim) <> columns then goto exit1 ' invalid file
    parse st, temp1(), delim
    for j = 1 to columns
    dataarray(j, i) = temp1(j)
    next
    next
    control disable hdlg, %idc_button420
    control disable hdlg, %idc_button430
    function = 1
    end if
    exit1:
    mouseptr 1
    function = 1
    end function
    '
    sub synchronizelistviews(byval h1 as dword, byval h2 as dword)
    local rc1 as rect, rc2 as rect, i as long, j as long, w as long
    '
    ' synchronize vertical scrolling
    rc1.nleft = %lvir_bounds : sendmessage h1, %lvm_getitemrect, 0, varptr(rc1)
    rc2.nleft = %lvir_bounds : sendmessage h2, %lvm_getitemrect, 0, varptr(rc2)
    sendmessage h2, %lvm_scroll, 0, rc2.ntop - rc1.ntop
    '
    ' ensure that left (row header) listview always has handle h2 in the following.
    getwindowrect h1, rc1 : getwindowrect h2, rc2 : if rc1.nleft < rc2.nleft then swap h1, h2
    '
    ' adjust column width of left (row header) listview to ensure same horizontal scroll bar status
    ' (present or absent) in both listviews. (if the column width is greater than the width of a
    ' listview, then a horizontal scroll bar is displayed - otherwise it is not displayed.)
    i = sendmessage(h1, %lvm_getcountperpage, 0, 0)
    j = sendmessage(h2, %lvm_getcountperpage, 0, 0)
    w = sendmessage(h2, %lvm_getcolumnwidth, 0, 0)
    do
    w = w + sgn(j - i) : sendmessage h2, %lvm_setcolumnwidth, 0, maklng(w, 0)
    j = sendmessage(h2, %lvm_getcountperpage, 0, 0)
    loop until i = j
    '
    ' ensure that left (row header) listview is always scrolled maximally to the left.
    rc2.nleft = %lvir_bounds : sendmessage h2, %lvm_getitemrect, 0, varptr(rc2)
    sendmessage h2, %lvm_scroll, rc2.nleft, 0
    end sub
    '
    sub combosel(byref head() as string, byval columns as long, byval hdlg as long, byval ctl as long, byref alphnum() as long)
    local cval as long, txt as string, i as long
    control send hdlg, ctl, %cb_getcursel, 0,0 to cval
    ' set numerical or alphabetical acccording to the type of the variable
    if ctl = 11 then control send hdlg, ctl + 20, %cb_setcursel, alphnum(cval+1), 0
    if ctl > 11 then
    combobox get text hdlg, ctl to txt
    for i=1 to columns
    if txt=head(i) then control send hdlg, ctl + 20, %cb_setcursel, alphnum(i), 0
    next
    end if
    ' empty next comboboxes
    for i = ctl + 1 to 15 : control send hdlg, i, %cb_resetcontent, 0, 0 : next
    ' put all variables except the selected ones in next comboboxes
    if ctl = 11 then
    for i=0 to columns - ctl + 10
    if columns>=2 and i<>cval then combobox add hdlg, ctl + 1, head(i+1)
    next
    elseif (ctl>11 and ctl<15) then
    for i=0 to columns - ctl + 10
    control send hdlg, ctl, %cb_setcursel, i, 0
    combobox get text hdlg, ctl to txt
    if i<>cval then combobox add hdlg, ctl + 1, txt
    next
    control send hdlg, ctl, %cb_setcursel, cval, 0
    end if
    end sub
    '
    ' main dialog procedure
    callback function dlgproc() as long
    local hctl as dword, lstyle as long, i as long, res as long
    static hmnu as dword, hsubmenu as dword, hsubmenu2 as dword
    static pafuout as string, pafu as string, delim as string
    static h1 as dword, h2 as dword
    static columns as long, rows as long
    static prevtime as double
    static wide1 as long, high1 as long, wide2 as long, high2 as long
    static x1 as long,y1 as long, x2 as long, y2 as long
    dim head(1 to 10) as static string, dataarray(1 to 10) as static string, indx(1 to 10) as static long
    dim prio(1 to 1, 1 to 1) as static long
    dim maxlen(1 to 10) as static long, alphnum(1 to 10) as static long
    local t1 as double, t2 as double
    local pnmh as nmhdr ptr
    local lplvdispinfo as lv_dispinfo ptr
    local pnm as nmlvcustomdraw ptr
    local szstring as asciiz * 256

    select case cbmsg
    case %wm_initdialog
    delim = $tab
    lstyle = %ws_child or %ws_visible or %ss_center
    control add label, cbhndl, %idc_label101, "1st:", 0, 14, 14, 10, lstyle
    control add label, cbhndl, %idc_label102, "2nd:", 0, 28, 14, 10, lstyle
    control add label, cbhndl, %idc_label103, "3rd:", 0, 42, 14, 10, lstyle
    control add label, cbhndl, %idc_label104, "4th:", 0, 56, 14, 10, lstyle
    control add label, cbhndl, %idc_label105, "5th:", 0, 70, 14, 10, lstyle
    control add label, cbhndl, %idc_label125, "variable sorting priority:", 14, 2, 116, 10, lstyle
    control add label, cbhndl, %idc_label135, "ascending or descending:", 146, 2, 105, 10, lstyle
    control add label, cbhndl, %idc_label145, "alphabetic or numerical:", 270, 2, 86, 10, lstyle
    lstyle = %ws_child or %ws_visible or %ss_left
    control add label, cbhndl, %idc_label150, "sorting time:", 6, 226, 104, 12, lstyle
    '
    lstyle = %ws_child or %ws_visible or %ws_tabstop or %cbs_dropdownlist or %cbs_hasstrings or %cbs_nointegralheight
    control add combobox, cbhndl, %idc_combobox11, , 16, 12, 120, 80, lstyle
    control add combobox, cbhndl, %idc_combobox12, , 16, 26, 120, 80, lstyle
    control add combobox, cbhndl, %idc_combobox13, , 16, 40, 120, 80, lstyle
    control add combobox, cbhndl, %idc_combobox14, , 16, 54, 120, 80, lstyle
    control add combobox, cbhndl, %idc_combobox15, , 16, 68, 120, 80, lstyle
    '
    control add combobox, cbhndl, %idc_combobox21, , 144, 12, 114, 80, lstyle
    control add combobox, cbhndl, %idc_combobox22, , 144, 26, 114, 80, lstyle
    control add combobox, cbhndl, %idc_combobox23, , 144, 40, 114, 80, lstyle
    control add combobox, cbhndl, %idc_combobox24, , 144, 54, 114, 80, lstyle
    control add combobox, cbhndl, %idc_combobox25, , 144, 68, 114, 80, lstyle
    for i = 21 to 25
    combobox add cbhndl, i, "ascending (smallest or a first)"
    combobox add cbhndl, i, "descending (largest or z first)"
    control send cbhndl, i, %cb_setcursel, 0, 0
    next
    '
    control add combobox, cbhndl, %idc_combobox31, , 266, 12, 106, 80, lstyle
    control add combobox, cbhndl, %idc_combobox32, , 266, 26, 106, 80, lstyle
    control add combobox, cbhndl, %idc_combobox33, , 266, 40, 106, 80, lstyle
    control add combobox, cbhndl, %idc_combobox34, , 266, 54, 106, 80, lstyle
    control add combobox, cbhndl, %idc_combobox35, , 266, 68, 106, 80, lstyle
    for i = 31 to 35
    combobox add cbhndl, i, "alphabetical"
    combobox add cbhndl, i, "numerical"
    control send cbhndl, i, %cb_setcursel, 0, 0
    next
    '
    initcommoncontrols
    '
    control add "syslistview32", cbhndl, %idc_listview400, ", 44, 84, 328, 134, _
    %ws_child or %ws_visible or %ws_tabstop or %lvs_report or %lvs_showselalways _
    or %lvs_ownerdata or %ws_border, %ws_ex_left or %ws_ex_rightscrollbar
    control add "syslistview32", cbhndl, %idc_listview410, ", 6, 84, 37, 134, _
    %ws_child or %ws_visible or %ws_tabstop or %lvs_report or %lvs_showselalways _
    or %lvs_ownerdata or %ws_border, %ws_ex_left or %ws_ex_leftscrollbar
    control handle cbhndl, %idc_listview400 to h1
    control handle cbhndl, %idc_listview410 to h2
    control get size cbhndl, %idc_listview400 to wide1, high1
    control get size cbhndl, %idc_listview410 to wide2, high2
    control get loc cbhndl, %idc_listview400 to x1, y1
    control get loc cbhndl, %idc_listview410 to x2, y2
    dialog units cbhndl, x1, y1 to pixels x1, y1
    dialog units cbhndl, x2, y2 to pixels x2, y2
    dialog units cbhndl, wide1, high1 to pixels wide1, high1
    dialog units cbhndl, wide2, high2 to pixels wide2, high2
    movewindow h2, x2, y2, wide2, high2, %true
    movewindow h1, x2+wide2-1, y2, wide1+2, high1, %true
    '
    lstyle = %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop
    control add button, cbhndl, %idc_button420, "show &original sequence", 110, 224, 118, 12, lstyle or %ws_disabled
    control add button, cbhndl, %idc_button430, "&sort", 240, 224, 78, 12, lstyle or %ws_disabled
    control add button, cbhndl, %idc_button440, "&end", 330, 224, 41, 12, lstyle
    '
    menu new bar to hmnu
    menu new popup to hsubmenu
    menu add popup, hmnu, "&start", hsubmenu, %mf_enabled
    menu add string, hsubmenu, "use &default data", 505, %mf_enabled
    menu add string, hsubmenu, "&open file", 510, %mf_enabled
    menu add string, hsubmenu, "save file &as", 515, %mf_grayed
    menu add string, hsubmenu, "-", 0, 0
    menu add string, hsubmenu, "e&xit", 525, %mf_enabled
    menu new popup to hsubmenu
    menu add popup, hmnu, "&help", hsubmenu, %mf_enabled
    menu add string, hsubmenu, "&help", 600, %mf_enabled
    menu add string, hsubmenu, "-", 0, 0
    menu add string, hsubmenu, "&about", 605, %mf_enabled
    menu attach hmnu, cbhndl
    '
    case %wm_command
    'messages from controls and menu items are handled here.
    '-------------------------------------------------------
    select case cbctl
    case %idcancel : if cbctlmsg = %bn_clicked then dialog end cbhndl, 0
    '
    case %idc_combobox11, %idc_combobox12, %idc_combobox13,%idc_combobox14, %idc_combobox15
    if cbctlmsg=%cbn_selchange then
    call combosel(head(), columns, cbhndl, cbctl, alphnum())
    control enable cbhndl, %idc_button430 ' sort
    end if
    case %idc_button420 ' show original sequence
    mouseptr 11 : for i = 1 to rows : indx(i) = i : next
    invalidaterect cbhndl, byval %null, %false : mouseptr 1
    '
    case %idc_button430 ' do sorting
    local j&,jj&,k&,kk&,l&,cvartx$,calnu&,casds&,imax&',length&
    if cbctlmsg=%bn_clicked then
    mouseptr 11
    redim indx(1 to rows)
    redim prio(0 to 2, 1 to columns)
    imax = min(5, columns)
    for i&=1 to imax&
    combobox get text cbhndl, i+10 to cvartx
    control send cbhndl, i+20, %cb_getcursel, 0,0 to casds
    control send cbhndl, i+30, %cb_getcursel, 0,0 to calnu
    'prio(0,n) holds the n-th sorting priority variable number
    for j=1 to columns
    if head(j)=cvartx then prio(0,i)=j
    next
    'prio(1,n) holds information on whether the n'th sorting
    ' priority variable should be sorted as
    ' a string (value=0) or as
    ' a numeric value (value=1)
    prio(1,i)=calnu

    'prio(2,n) holds information on whether the n'th sorting
    ' priority variable should be sorted
    ' ascending (value=1) or descending (value=-1)
    if casds=0 then prio(2,i)=1 else prio(2,i)=-1
    next
    t1 = currenttimepointinseconds
    call posisort (byref dataarray(),byref indx(), byval columns,byval rows, _
    byref prio())
    t2 = currenttimepointinseconds
    control set text cbhndl, %idc_label150, "sorting time: "+ format$(t2 - t1, "######.#########")+" sec."

    control enable cbhndl, %idc_button420
    invalidaterect cbhndl, byval %null, %false
    end if
    mouseptr 1
    '
    case %idc_button440 : if cbctlmsg = %bn_clicked then dialog end cbhndl, 0 ' exit
    '
    ' process menu items
    case 505 ' get default data
    call generatedefaultdata(columns, rows, head(), dataarray(), cbhndl)
    call checkdata(columns, rows, head(), dataarray(), cbhndl, alphnum(), maxlen(), indx())
    call displaydata(columns, rows, head(), dataarray(), cbhndl, alphnum(), maxlen())
    enablemenuitem hmn

  • #2
    Erik, the program does not run OK with PBWin 7.04
    There are some variable declarations that needed fix, like
    Code:
    LOCAL RowIndex, B, G, D, E, F, De, J, X, fl, I, K, M, N, Dept AS LONG
    
    Changed to:
    
    LOCAL RowIndex AS LONG, B AS LONG, G AS LONG, D AS LONG, E AS LONG, F AS LONG, De AS LONG, J AS LONG, X AS LONG, fl AS LONG, I AS LONG, K AS LONG, M AS LONG, N AS LONG, Dept AS LONG
    When finally compiled, the listboxes wouldn´t show

    Nice work though.


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

    Comment


    • #3
      Pedro, Thanks for your comments. I have changed the program to run
      also on PBWin 7.0. If you still are having problems, try to reduce
      the number of rows in SUB GenerateDefaultData. That should work. You
      need to load some data to fill the listviews - either by using the
      default data or by loading a TAB-separated ASCII (text) file.

      Best regards,

      Erik

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




      [This message has been edited by Erik Christensen (edited March 07, 2006).]

      Comment

      Working...
      X