list box limits

[Paul Squires]

#1 you should look at all of Jose's tooltip functions in his AfxCtl.inc source code file.

[raymw]

#2 does the job, thanks. But, it has got me thinking in other directions... Is it possible to edit the font, say background colour, for an individual item in the listbox? I've yet to look into Jose's functions

[Pierre Bellisle]

Here is a listbox demo that can display 2,147,483,646 items via a subclass to overcome SB_THUMBPOSITION and SB_THUMBTRACK 16bits limits. This LBS_OWNERDRAWFIXED listbox also use different colors and fonts for item display.

Code Select Expand


#Define JumpCompiler "<D:\Free\64\fbc.exe>"
#Define JumpCompilerCmd "<-s gui -w pedantic "D:\Free\bas\~~Default.rc">"

#Print Coded on FreeBASIC 1.05.0
#Ifdef __FB_64BIT__
  #Print  64bit compiler used
#Else
  #Print  32bit compiler used
#EndIf
'_____________________________________________________________________________

#define unicode

#Include Once "Windows.bi"
#Include Once "String.bi" 'Format
#Include Once "Win\ShellApi.bi"

#Define ButtonExit       101
#Define Listbox          201
#Define ListboxItemCount MAXDWORD / 2 '2,147,483,646 items
#Define AppName          "Big ListBox "

Dim Shared As HINSTANCE hInstance : hInstance = GetModuleHandle(NULL)
'_____________________________________________________________________________

Sub EnumCharSet(ByRef elf As ENUMLOGFONT, ByRef ntm As NEWTEXTMETRIC, _
                ByVal FontType As Long, ByVal CharSet As Long)
'Get type of character set - ansi, symbol.. a must for some fonts.
CharSet = elf.elfLogFont.lfCharSet

End Sub
'_____________________________________________________________________________

Function MakeFontEx(ByVal hDC As HDC, ByVal pwsFontName As WString Pointer, ByVal PointSize As Long, _
                    ByVal Angle As Long, ByVal fBold As Long, ByVal fItalic As DWORD, _
                    ByVal fUnderline As DWORD, ByVal StrikeThru As DWORD) As HFONT

'Create a font and return its handle. Ex: hFont = MakeFontEx(hDC, "Segoe UI", 9, 0, 0, 0, 0, 0)
Dim CharSet  As LParam
Dim CyPixels As Long

If hDC = 0 Then
   hDC      = GetDC(HWND_DESKTOP)
   CyPixels = GetDeviceCaps(hDC, LOGPIXELSY)
   EnumFontFamilies(hDC, pwsFontName, Cast(FONTENUMPROCW, ProcPtr(EnumCharSet)), CharSet)
   ReleaseDC(HWND_DESKTOP, hDC)
Else
   CyPixels = GetDeviceCaps(hDC, LOGPIXELSY)
   EnumFontFamilies(hDC, pwsFontName, Cast(FONTENUMPROCW, ProcPtr(EnumCharSet)), CharSet)
End If

PointSize = 0 - (PointSize * CyPixels) \ 72

Function = CreateFont(PointSize, 0, _                         'Height, Width (default=0),
                       Angle, Angle, _                         'Escapement(angle), Orientation,
                       fBold, _                                'Weight (%FW_DONTCARE = 0, %FW_NORMAL = 400, %FW_BOLD = 700),
                       fItalic, fUnderline, StrikeThru, _      'Italic, Underline, Strike thru,
                       CharSet, OUT_TT_PRECIS, _               'Char set, Output precision,
                       CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, _ 'ClipPrecision, Quality,
                       FF_DONTCARE,  pwsFontName)              'Pitch and family, Typeface

End Function
'_____________________________________________________________________________

FUNCTION ListboxProc(BYVAL hListbox AS HWND, BYVAL Msg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LONG
'For big Listbox, due to the way where designed, it may be difficult to scroll past the first 65,536 items.
'The 16 bit returned with SB_THUMBTRACK and SB_THUMBPOSITION set this barrier.
'A workaround for this is simply to Subclass the ListBox to intercept those messages
'to set the ScrollBar 32bit position and scroll the ListBox accordingly.
'Mostly exe using Common-Controls 6.0.0.0 seems to need this correction.

'MSDN: WM_VSCROLL message carries only 16 bits of scroll box position data in HiWord of wParam.
'Thus, applications that rely solely on WM_VSCROLL and WM_HSCROLL for
'scroll position data have a practical maximum position value of 65,535.

Dim    ScrollInf    AS SCROLLINFO
Static pListboxProc AS WndProc

IF Msg = WM_VSCROLL AND (wParam AND &h0000FFFE) = 4 THEN 'wParam AND ... is a quick way to test for SB_THUMBPOSITION(4) or SB_THUMBTRACK(5)
   ScrollInf.cbSize = SIZEOF(SCROLLINFO)
   ScrollInf.fMask  = SIF_ALL OR SIF_DISABLENOSCROLL
   GetScrollInfo(hListbox, SB_VERT, @ScrollInf)
   ScrollInf.nPos = ScrollInf.nTrackPos
   SetScrollInfo(hListbox, SB_VERT, @ScrollInf, TRUE) 'Fix scrollbar thumb position avoiding the Lisbox 16 bit engine.
   SendMessage(hListbox, LB_SETTOPINDEX, ScrollInf.nTrackPos, 0) 'Scroll listbox
ELSE
   IF hListbox = 0 THEN pListboxProc = Cast(WndProc, wParam) 'Auto asign pListboxProc for later in WM_NCDESTROY
   IF Msg = WM_KEYDOWN And (wParam = VK_HOME Or wParam = VK_END) THEN
     ScrollInf.cbSize = SIZEOF(SCROLLINFO)
     ScrollInf.fMask  = SIF_POS 'HOME and END scrool half the way with 2,147,483,6460
     IF wParam = VK_HOME THEN ScrollInf.nPos = 0 ELSE ScrollInf.nPos = ListboxItemCount - 1
     SetScrollInfo(hListbox, SB_VERT, @ScrollInf, TRUE)
     SendMessage(hListbox, LB_SETTOPINDEX, ScrollInf.nPos, 0)
     EXIT FUNCTION
   END IF
   IF Msg = WM_NCDESTROY THEN SetWindowLongPtr(hListbox, GWLP_WNDPROC, Cast(LONG_PTR, pListboxProc)) 'Unsubclass listbox
   FUNCTION = CallWindowProc(pListboxProc, hListbox, Msg, wParam, lParam) 'Let the Listbox engine finish the work
END IF

END FUNCTION
'_____________________________________________________________________________

Function WndProc(ByVal hWnd As HWND, ByVal uMsg As UINT, ByVal wParam As WPARAM, ByVal lParam As LPARAM) As Integer
Static hFont            As HFONT
Static hFontArialBlack  As HFONT
Dim    hFontGenuine     As HFONT
Static hListbox         As HWND
Static hButtonExit      As HWND
Dim    Even             As LONG

Function = 0

Select Case (uMsg)

   Case WM_CREATE
     'Get Windows default font
     Dim NotClientMetrics As NONCLIENTMETRICS
     NotClientMetrics.cbSize = SizeOf(NONCLIENTMETRICS)
     SystemParametersInfo(SPI_GETNONCLIENTMETRICS, NotClientMetrics.cbSize, @NotClientMetrics, 0)
     hFont = CreateFontIndirect(@NotClientMetrics.lfMessageFont)

     'Use a second font
     hFontArialBlack = MakeFontEx(0, "Arial Black", 9, 0, True, 0, 0, 0)

     'Button Exit
     hButtonExit = CreateWindowEx(0, "Button", "E&xit", _
                                  WS_CHILD Or WS_VISIBLE Or BS_CENTER Or WS_TABSTOP Or _
                                  BS_NOTIFY Or BS_TEXT Or BS_VCENTER, _
                                  10, 325, 205, 30, _
                                  hWnd, Cast(HMENU, ButtonExit), _
                                  hInstance, NULL)
     SendMessage(hButtonExit, WM_SETFONT, Cast(WPARAM, hFont), TRUE)

     'Listbox
     hListbox   = CreateWindowEx(WS_EX_CLIENTEDGE, "Listbox", "", _
                                 WS_CHILD OR WS_VISIBLE OR WS_TABSTOP OR LBS_OWNERDRAWFIXED OR _
                                 LBS_NODATA OR LBS_NOTIFY OR WS_TABSTOP OR WS_VSCROLL, _
                                 10, 10, 205, 310, _
                                 hWnd, Cast(HMENU, Listbox), _
                                 hInstance, NULL)
     SendMessage(hListbox, LB_SETCOUNT, Cast(UInteger, MAXLONG), 0) '34,463
     SendMessage(hListbox, WM_SETFONT, Cast(UInteger, hFont), TRUE)

     'Subclass listbox with a a one liner and no variables needed...
     ListboxProc(0, 0, SetWindowLongPtr(hListbox, GWLP_WNDPROC, Cast(LONG_PTR, ProcPtr(ListboxProc))), 0)

    Case WM_COMMAND
     Select Case LoWord(wParam)

       CASE Listbox
         IF HiWord(wParam) = LBN_SELCHANGE THEN
           SetWindowText(hWnd, "Index is " & STR$(SendMessage(hListbox, LB_GETCURSEL, 0, 0)))
         END IF

        Case ButtonExit, IDCANCEL
          If HiWord(wParam) = BN_CLICKED Then
            PostMessage(hWnd, WM_CLOSE, 0, 0)
            Exit Function
          EndIf

     End Select

   Case WM_DRAWITEM
     If wParam = Listbox Then
       Dim pDrawItemStructure AS DRAWITEMSTRUCT Pointer
       pDrawItemStructure = Cast(pDRAWITEMSTRUCT, lParam)

       If pDrawItemStructure->itemID <> &HFFFFFFFF THEN 'Is list is empty?
         Even = (pDrawItemStructure->itemID And 1) 'A simple Odd/Even flip-flop for the demo
         If (pDrawItemStructure->itemAction = ODA_DRAWENTIRE) OR (pDrawItemStructure->itemAction = ODA_SELECT) Then
           If (pDrawItemStructure->itemState AND ODS_SELECTED) = False Then                                          'Not selected
             If Even Then                                                                                            '  Even colors
               FillRect(pDrawItemStructure->hDC, @pDrawItemStructure->rcItem, GetSysColorBrush(COLOR_ACTIVECAPTION)) '    Cls
               SetBkColor(pDrawItemStructure->hDC, GetSysColor(COLOR_ACTIVECAPTION))                                 '    Text background
               SetTextColor(pDrawItemStructure->hDC, GetSysColor(COLOR_INFOBK))                                      '    Text color
             Else                                                                                                    '  Odd color
               FillRect(pDrawItemStructure->hDC, @pDrawItemStructure->rcItem, GetSysColorBrush(COLOR_WINDOW))        '    Cls
               SetBkColor(pDrawItemStructure->hDC, GetSysColor(COLOR_WINDOW))                                        '    Text background
               SetTextColor(pDrawItemStructure->hDC, GetSysColor(COLOR_WINDOWTEXT))                                  '    Text color
             EndIf
           Else                                                                                                      'Selected
             FillRect(pDrawItemStructure->hDC, @pDrawItemStructure->rcItem, GetSysColorBrush(COLOR_HIGHLIGHT))       'Cls
             SetBkColor(pDrawItemStructure->hDC, GetSysColor(COLOR_HIGHLIGHT))                                       'Text background
             SetTextColor(pDrawItemStructure->hDC, GetSysColor(COLOR_HIGHLIGHTTEXT))                                 'Text color
           EndIf

           'Draw some text
           Dim sElement AS WSTRING * 50
           sElement = "Element " & FORMAT(pDrawItemStructure->itemID, "#,")
           If Even Then hFontGenuine = SelectObject(pDrawItemStructure->hDC, hFontArialBlack)
           DrawText(pDrawItemStructure->hDC, Cast(LPCTSTR, STRPTR(sElement)), _
                    LEN(sElement), @pDrawItemStructure->rcItem, DT_SINGLELINE OR DT_LEFT OR DT_VCENTER)
           If Even Then SelectObject(pDrawItemStructure->hDC, hFontGenuine)

           'Draw grid lines
           Dim hPen As HPEN
           hPen = SelectObject(pDrawItemStructure->hDC, CreatePen(PS_SOLID, 1, GetSysColor(COLOR_3DFACE)))
           MoveToEx(pDrawItemStructure->hDC, 0, pDrawItemStructure->rcItem.Bottom - 1, BYVAL NULL)
           LineTo(pDrawItemStructure->hDC, pDrawItemStructure->rcItem.Right, pDrawItemStructure->rcItem.Bottom - 1)
           DeleteObject(SelectObject(pDrawItemStructure->hDC, hPen))
           Function = TRUE
         END IF

       END IF
     END IF

   Case WM_SIZE
     If wParam <> SIZE_MINIMIZED Then
       Dim As LONG SizeX = LOWORD(LPARAM)
       Dim As LONG SizeY = HIWORD(LPARAM)
       MoveWindow(hListbox, 10, 10, SizeX - 20, SizeY - 50, TRUE)
       MoveWindow(hButtonExit, 10, SizeY - 35, SizeX - 20, 30, TRUE)
     End IF

   Case WM_DESTROY
     DeleteObject(hFont)
     DeleteObject(hFontArialBlack)
     PostQuitMessage(0)
     Exit Function

End Select

Function = DefWindowProc(hWnd, uMsg, wParam, lParam)

End Function
'_____________________________________________________________________________

Function WinMain(ByVal hInstance As HINSTANCE, ByVal hPrevInst As HINSTANCE, _
                 ByVal CmdLine As WString Ptr, ByVal CmdShow As Integer) As UINT
Dim wsAppName  As WString * 128
Dim WinClass   As WNDCLASS
Dim WindowSize As SIZEL
Dim hWnd       As HWND
Dim wMsg       As MSG

wsAppName              = AppName & " - " & SizeOf(UInteger) * 8
WindowSize.cx          = 240
WindowSize.cy          = 390
WinClass.hIcon         = ExtractIcon(hInstance, "%SystemRoot%\system32\shell32.dll", 293)
WinClass.style         = CS_HREDRAW Or CS_VREDRAW
WinClass.lpfnWndProc   = ProcPtr(WndProc)
WinClass.cbClsExtra    = 0
WinClass.cbWndExtra    = 0
WinClass.hInstance     = hInstance
WinClass.hCursor       = LoadCursor(NULL, IDC_ARROW)
WinClass.hbrBackground = Cast(HGDIOBJ, COLOR_BTNFACE + 1) 'Default color
WinClass.lpszMenuName  = NULL
WinClass.lpszClassName = @wsAppName

If (RegisterClass(@WinClass)) Then
   hWnd = CreateWindowEx(WS_EX_WINDOWEDGE, _
                         wsAppName, wsAppName, _
                         WS_OVERLAPPED OR WS_CLIPCHILDREN Or WS_DLGFRAME Or WS_BORDER Or WS_VISIBLE Or WS_CAPTION Or _
                         WS_MAXIMIZEBOX Or WS_MINIMIZEBOX Or WS_SIZEBOX Or WS_SYSMENU , _
                         (GetSystemMetrics(SM_CXSCREEN) - WindowSize.cx) / 2, _ 'PosX screen center
                         (GetSystemMetrics(SM_CYSCREEN) - WindowSize.cy) / 2, _ 'PosY screen center
                         WindowSize.cx, WindowSize.cy, _ 'SizeX, SizeY
                         NULL, NULL, hInstance, NULL)

   ShowWindow(hWnd, SW_SHOW)
   UpdateWindow(hWnd)

   While GetMessage(@wMsg, ByVal NULL, 0, 0) > 0
     If IsDialogMessage(hWnd, @wMsg) = 0 Then
       TranslateMessage(@wMsg)
       DispatchMessage(@wMsg)
     End If
   Wend

  End If
  DestroyIcon(WinClass.hIcon)
  Function = wMsg.message

End Function
'_____________________________________________________________________________

End WinMain(hInstance, NULL, Command(), SW_NORMAL) 'Call main() and return the error code to the OS
'_____________________________________________________________________________
'


[raymw]

Thanks Pierre, Looks interesting and useful. Once I've sorted out my current bugs features I'll maybe look and see if I can incorporate some colour changes to selected text.

[raymw]

I've been trying to speed up the processing on the large files, and in the absence of knowing of any free profiling software, I've been using printing timer values to the console window. Anyway, I've found a major time delay is in code similar to the following

Code Select Expand

   
         Dim aa as String
         Dim lk as  Long
         Dim num as Double
         Dim t1 as Double
         Dim t2 as Double
         t1=Timer
         
                 
         FF_ListBox_ResetContent( hwnd_frmmain_listg)
         FF_ListBox_ResetContent(hwnd_frmmain_listf)
       
         aa = ""
         lk = FF_ListBox_GetCount( hwnd_frmmain_listg)
                 
      For j as Long = 0 To maxlines
            If arrayg(j)="" Then Goto getnextln
               aa= arrayg(j)
     
     'check list                           
             
            If lk =0 Then
               FF_ListBox_AddString( hwnd_frmmain_listg,aa )
               lk=1
               Goto getnextln
            End If
       
        'check if there
       
        For k as Long = 0 To lk
              If aa = FF_ListBox_GetText( hwnd_frmmain_listg,k ) Then Goto getnextln
        Next
               FF_ListBox_AddString( hwnd_frmmain_listg,aa )
               lk=lk+1

     getnextln:
        Next

where maxlines is 600,000 it takes about 100 seconds to process. The arrayg is sparsely populated with maybe 3 or 4 different value (but there can be many instances of an individual value), and the code goes through the list and creates another list (listg) consisting of the individual values found. Any ideas of getting a significant speed improvement (other than changing pc) . Would there be significant speed improvement, if instead of using the ff listbox listg, I temporarily stored/checked values in an array, and copied over at the end of the processing? I've already slightly reduced the time by using the lk count instead of calling the ff getcount function.

Ok, changed it around a bit....
Whereas the above code was taking 153 seconds to process for a particular file, it now takes 0.119 seconds. The arrayg should only have values between 0 and 99, so I simply entered a value in another array, dimensioned to 100. Had to initially fill said array with a negative number. fwiw I've copied a chunk of the relevant code here

Code Select Expand

       Dim aa as String
         Dim lk as  Long
         Dim num as Double
         Dim t1 as Double
         Dim t2 as Double
         t1=Timer
         Dim arra (100) as Integer
         Dim vg as Integer
          Dim j as Integer       
         FF_ListBox_ResetContent( hwnd_frmmain_listg)
         FF_ListBox_ResetContent(hwnd_frmmain_listf)
       
       For j= 0 To 100
       arra(j)=-9
       Next j
               
         For j  = 0 To maxlines
         If arrayg(j)="" Then Goto getout
               vg=Val(arrayg(j) )
               arra(vg)= vg
         
         getout:
         Next j
' copy to listbox
         For  j  = 0 To 100
         If   arra(j) > -9   Then   FF_ListBox_AddString( hwnd_frmmain_listg,Format(j,"00" ) )
         Next  j
 
     
     t2=Timer
         ?t1,t2,t2-t1, "gandf just g"
             aa=""
             t1=Timer

[Paul Squires]

I would love to help you optimize your code or use different algorithms but the code you posted is meaningless to me without context. I have no idea what is being read, why the different arrays exist, and what kind of data is in each array and their purpose. I am happy that you were able to find a solution that cut down your processing time so significantly 

[raymw]

Hi Paul,
would you like a more detailed description of what I was trying to do?

[raymw]

OK, maybe this is more understandable - I've added a few more comments and removed items that are not relevant to the problem. arrayg and listg are defined/dimensioned outside of this snippet. It's creating a list of unique values in listg from whatever values that are unique or duplicated in arrayg

Code Select Expand

 
         Dim aa as String 'temp string
         Dim lk as  Long  'size of listg
                       
       
'listg is a listbox to hold a list of the unique values from arrayg
       
         aa = ""
         lk = FF_ListBox_GetCount( hwnd_frmmain_listg)
' there may already be values in listg
'maxlines can be a value 1000000 or more (the size of arrayg )
'arrayg may or may not have a value in each position.     
      For j as Long = 0 To maxlines
' if the value in arrayg(j) is a blank then get the next one
            If arrayg(j)="" Then Goto getnextln
  'set aa to the value if not blank (saves time 'cos its used again )         
    aa= arrayg(j)
     
  'if listg is empty, then add aa to listg  and inc list size                         
             
            If lk =0 Then
               FF_ListBox_AddString( hwnd_frmmain_listg,aa )
               lk=1
               Goto getnextln
            End If
       
'if listg is not empty, then check if a value for aa is already there
' only add aa if value is not already in listg also inc list size   
       
        For k as Long = 0 To lk
              If aa = FF_ListBox_GetText( hwnd_frmmain_listg,k ) Then Goto getnextln
        Next
'not found aa in listg, so add it in now
               FF_ListBox_AddString( hwnd_frmmain_listg,aa )
               lk=lk+1

     getnextln:
        Next

If arrayg is only a few thousand items, the code runs fast enough, but when a million or so it takes much longer. The time more or less exponentially increases as more values of listg are processed , since each time a value is added it has to check the existing listg.

Not sure if that makes it any clearer...

here's the sort of thing it does

arrayg
50,10,50, ,60,50,10,10,10,00, ,70,50,50,70, ,70,10,10,10,10

listg
50,10,60,70

[Paul Squires]

Hi Ray,

Here you go... this should be faster than your current code. Give it a shot and let me know if it needs to be tweaked more.

Code Select Expand


' Per Raymw's description:
' It's creating a list of unique values in listg from whatever values that are unique or duplicated in arrayg
'
' Quick internet search to find array remove duplicate code for FreeBasic
' https://www.rosettacode.org/wiki/Remove_duplicate_elements#FreeBASIC
'
' It appears that your arrays are strings so I modifed the code to work with
' string arrays instead of integer arrays. Also modified to skip array elements
' that are empty or evaluate to zero.

Sub RemoveArrayDuplicates( a() As string, b() As string)
  Dim lb As Integer = LBound(a)
  Dim ub As Integer = UBound(a)
  If ub = -1 Then Return   ' empty array
  ' Initialize the first element of b array to first non-zero element of a.
  for i as integer = lb to ub
     if val(a(i)) > 0 then
        lb = i: exit for
     END IF
  NEXT
  Redim b(lb To ub)
  b(lb) = a(lb)

  Dim count As Integer = 1
  Dim unique As Boolean

  For i As Integer = lb + 1 To ub
    if val(a(i)) = 0 then continue for
    unique = True
    For j As Integer = lb to i - 1
      If a(i) = a(j) Then
        unique = False
        Exit For
      End If
    Next j
    If unique Then
      b(lbound(b) + count) = a(i)
      count += 1
    End If
  Next i

  If count > 0 Then Redim Preserve b(lbound(b) To lbound(b) + count - 1) 
End Sub

'arrayg
' 50,10,50, ,60,50,10,10,10,00, ,70,50,50,70, ,70,10,10,10,10
'
'listg
' 50,10,60,70

Dim arrayg(...) As string = {"50","10","50","","60","50","10","10","10","00","","70","50","50","70","","70","10","10","10","10"}
Dim listg() As string

RemoveArrayDuplicates( arrayg(), listg() )

For i As Integer = LBound(listg) To UBound(listg)
  Print listg(i); " ";
  ' You could also load your listg listbox here...
Next

Print
Print "Press any key to quit"
Sleep


[Paul Squires]

I noticed that for very large arrays (eg. 600,000) the function was very slow. I created a new set of code that works based on the assumption that data in the arrayg array can only be empty, 0, or a value between 1 and 100. The following code produces a sorted array of non-duplicate 600,000 items in less than a tenth of a second on my machine.

Code Select Expand


' Per Raymw's description:
' It's creating a list of unique values in listg from whatever values that are unique or duplicated in arrayg
'
' Because values in the arrayg array can only be empty, 0, or value from 1 to 100, we can craft
' an extremely fast routine that will identify the unique numbers in the array.

#Include "string.bi"   ' only used for the Format statement used below in output message


Sub RemoveArrayDuplicates( a() As string, b() As string)
   If ubound(a) = -1 Then Return   ' empty array
 
   ' Because the values in b() array must equate between 1 and 100 then we can
   ' create an array with O(1) access time similar to a hash structure.
   Dim ValidNumbers(1 to 100) as Boolean
   dim as long count, nValue, i, nextSlot
 
   ' Cycle through the a() array and check to see if it is already hit in our
   ' valid numbers array. If not, then set that array index to true.
   For i = LBound(a) To uBound(a)
      ' Bypass any empty or value 0 array values
      nValue = val(a(i))
      if nValue = 0 then continue for
      ' Value should be between 1 and 100 but if it is not then the assumption
      ' about the format of the a() array was wrong. Better check to ensure we
      ' don't get any array out of bounds errors.
      if (nValue < 1) or (nValue > 100) then continue for
      ' Finally, set the hit in our ValidNumbers array
      if ValidNumbers(nValue) = false then
         ValidNumbers(nValue) = true
         count = count + 1
      end if   
   next

   If count Then
      Redim b(1 to count)
      For i = LBound(ValidNumbers) To uBound(ValidNumbers)
         if ValidNumbers(i) = true then
            nextSlot = nextSlot + 1
            b(nextSlot) = str(i)
         end if     
      next
   END IF
End Sub


'' Function to a random number in the range [first, last), or {first <= x < last}.
Function rnd_range (first As Double, last As Double) As long
   Function = Rnd * (last - first) + first
End Function

Randomize

' Create a random array of 600,000 string elements
? "Creating random data array..."
reDim arrayg(599999) As string
Dim listg() As string
for i as integer = lbound(arrayg) to  ubound(arrayg)
   arrayg(i) = str(rnd_range(0, 100))
NEXT
?
? "Array created."
? "Calling RemoveArrayDuplicates..."

dim as single t1, t2
t1 = timer
RemoveArrayDuplicates( arrayg(), listg() )
t2 = timer

? "Time to remove duplicates for array of"; ubound(arrayg)-lbound(arrayg)+1; " elements: "; format(t2-t1, "##0.00"); " seconds."
'For i As Integer = LBound(listg) To UBound(listg)
'  Print listg(i); " ";
'  ' You could also load your listg listbox here...
'Next

Print
Print "Press any key to quit"
Sleep



[raymw]

Thanks Paul.
Your second version is very similar in principle to what I did in my second attempt, except you used a temporary boolean array, and mine was integer, and your code is neater. I was originally thinking of keeping a count of the unique 0 to 99 values in the integer array - the advantage being if I later deleted a value from the large array, then I'd only need to reduce the appropriate integer value in the integer list, but I don't think that would save any noticeable time compared to rebuilding the new integer list. Realising the values lie between 0 and 99 is the clue.

My early programming days in IBM Fortran (50 years ago, G & H iirc) trained me to use i,j,k as integers, (not often used l, m, but n always used as limit in for/next loops. e.g. for j= 0 to n) and also short variable names, less than four characters. I tend not to use the new fangled basic stuff, like while/wend and functions.

[raymw]

I suppose I may as well post here, since it is related to lengthy list boxes, in as much I'm trying to parse a file, separating various values into lists.  The original data looks something like the following

(130mm diam z 9mm deep)
N0001  G90
N0002  t32
(Begin Next Pass  at -3.000)
N0003  M06 S24000
N0004  M03
N34128  G01 X-17.5362 Y-7.0818 Z-2.3281
N34129  G01 X-17.5362 Y-7.0158 Z-2.3324
N34130  G01 X-17.5362 Y-6.9498 Z-2.3345
N34131  G01 X-17.5362 Y-6.8838 Z-2.3362
N34132  G01 X-17.5362 Y-6.8178 Z-2.3400
N34133  G01 X-17.5362 Y-6.7518 Z-2.3432
N34134  G01 X-17.5362 Y-6.6858 Z-2.3470

(a million or so lines of it.) basically it's a list of x,y,z coordinates (although there are additional axes, such as a,b,c, but I'm only concerned at the moment with x,y,z,a.)
Anyway, I read the lines from the file into an array, array1. I then parse each line in array1 for the various axis values, etc., saving the results into other arrays. This takes about 86 seconds for processing 1113262 records. I'm not sure if the speed can be much improved, but obviously I would like to get it to run faster.

Code Select Expand

Sub fill()  '  fills the columns       by parsing array1
 
   Dim ln as String   'line of code
   Dim k as Integer   'counter
   Dim t as Integer   ' total chars in ln
    Dim r as String    'result string if found
    Dim lns as String ' rhs of line
    Dim kk as Integer
   
    Dim t1 as Double 'for timer
    Dim t2 as Double 'for timer
    t1=Timer
 
   For i as Long = 0 To Maxlines   'for every line
   

   'set lines in arrays to blank
   
   arrayn(i)=""
   arrayg(i)=""
   arrayx(i)=""
   arrayy(i)=""
   arrayz(i)=""
   arrayf(i)=""
   arrayo(i)=""
   arraya(i)=""
   
      ln=  Array1(i)  'array1 is populated with g-code lines
      lns=ln           'lns is for right hand end of line
        t = Len (ln)  'ln is the line being considered
 
       
     For k = 0 To t  'go through line, character by character
     
       
            lns= Right(ln,t-k)
           
            ' none of N, X, Y etc. may not be present, and can be mixed upper/lower case
            ' N numbers need not be sequential
                  If UCase(Left (lns,1))= "N" Then   
         arrayn(i)= Format(Val(Right(lns,(t-(k+1)))),"0000" )
         Goto finnum
         End If
     
         'values are to be formatted to 4dp, usually
         'arrayo holds comments -should be enclosed in ()
         'arrayo also holds other codes, except N,G,X,Y,Z,A,F
                 
      If Left(lns,1)= "(" Then   'comment
                 arrayo(i)= lns
                               'get next line
                 Goto finline             
        End If
       
           
          If UCase(Left (lns,1))= "G" Then
         arrayg(i)= Format(Val(Right(lns,(t-(k+1)) )),"00")
         Goto finnum
         End If
         
        If UCase(Left (lns,1))= "X" Then
         arrayx(i)= Format(Val(Right(lns,(t-(k+1)))),"#.0000")
        Goto finnum 
        End If   
       
         If UCase(Left (lns,1))= "Y" Then
          arrayy(i)= Format(Val(Right(lns,(t-(k+1)))),"#.0000")
         Goto finnum
         End If
'       
       If UCase(Left (lns,1))= "Z" Then
        arrayz(i)= Format(Val(Right(lns,(t-(k+1)))),"#.0000")
         Goto finnum
         End If
         
           If UCase(Left (lns,1))= "A" Then
        arraya(i)= Format(Val(Right(lns,(t-(k+1)))),"#.0000")
         Goto finnum
         End If
         
'       
        If UCase(Left (lns,1))= "F" Then
         arrayf(i)= Format(Val(Right(lns,(t-(k+1)))),"#.0000")
         Goto finnum
         End If
         
       
'       
      finnum:   
       
        Next 
           
       'arrayo also holds other codes, except N,G,X,Y,Z,A,F
        'check for m, t, etc
                   kk=  InStr (LCase(ln),Any "bcdehijklmopqrstuvw" )
                      If kk>0 Then arrayo(i)=" "+Right(ln, t-kk+1)
                 
          'check for special characters       
                     kk=  InStr (ln,Any "!£$%^&*{}:@~#:<>?" )
                     If kk>0 Then arrayo(i)=" "+Right(ln, t-kk+1)
                 
   finline:     
                 
        Next  ' get next line
       
    t2=Timer   
 
      ?t1,t2,t2-t1 ,"b4 assign"  'takes 86 seconds to get to here - ignore the following wrt timing
       
   ' Assign the string arrays to the listboxes.
   
   SendMessage( HWND_FRMMAIN_code, VL_SETARRAY, Cast(WPARAM, VarPtr(Array1(0))) , Cast(LPARAM, UBound(Array1)) )
   SendMessage( HWND_FRMMAIN_VLISTn, VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayn(0))) , Cast(LPARAM, UBound(Arrayn)) )
   SendMessage( HWND_FRMMAIN_VLISTg,VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayg(0))) , Cast(LPARAM, UBound(Arrayg)) ) 
   SendMessage( HWND_FRMMAIN_VLISTx,VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayx(0))) , Cast(LPARAM, UBound(Arrayx)) )
   SendMessage( HWND_FRMMAIN_VLISTy,VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayy(0))) , Cast(LPARAM, UBound(Arrayy)) )
   SendMessage( HWND_FRMMAIN_VLISTz,VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayz(0))) , Cast(LPARAM, UBound(Arrayz)) )
   SendMessage( HWND_FRMMAIN_VLISTf, VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayf(0))) , Cast(LPARAM, UBound(Arrayf)) )
   SendMessage( HWND_FRMMAIN_VLISTo, VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayo(0))) , Cast(LPARAM, UBound(Arrayo)) )
   SendMessage( HWND_FRMMAIN_VLISTa, VL_SETARRAY, Cast(WPARAM, VarPtr(Arraya(0))) , Cast(LPARAM, UBound(Arraya)) )
   

   ' Refresh the listboxes so that the changes can visibly be seen.

   SendMessage( HWND_FRMMAIN_code, VL_REFRESH, 0, 0)     
   SendMessage( HWND_FRMMAIN_VLISTn, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTg, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTx, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTy, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTz, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTf, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTo, VL_REFRESH, 0, 0)   
   SendMessage( HWND_FRMMAIN_VLISTa, VL_REFRESH, 0, 0)
         
     
          gandf()
         
          hidew()
        t2=Timer   
 
      ?t1,t2,t2-t1 ,"ready to go"      'Note, this time is not significantly greater than time to 'b4 assign'
       
           
  End Sub


I'm not sure if my possibly bad coding habits impinge on performance. Somewhere, in the distant past, I read that to exit a loop you increased the counter, I tend to use a goto.
For code such as  arrayn(i)= Format(Val(Right(lns,(t-(k+1)))),"0000" )  is the processing quicker if I separate the calculations, e.g. v=t-(k+1), b= val(right,v), and finally arrayn(i)= format(b,"0000")?
I vaguely remember the myths that said always use a variable instead of a number, and some of the various nonsense/rules wrt sorting, which have since been disproved, but I've no idea as to what is currently supposed to be best practice.
Maybe, instead of the for/next going through each line, a character at a  time, checking for x,y,z, etc., it may be quicker to use instr(array1(i),"X"),  etc. for each wanted character on the whole line- it would save testing the numbers. Also, whether using Ucase would be quicker than testing for 'X' and 'x' separately. and so on...

edit to add- just thought of
Using Instr would need some thinking as to how to handle comments () which can be at the end of lines, or be the whole line, and can contain words that have x, y,z etc in there. Not insurmountable, but would most likely take a while.

[Paul Squires]

I have no idea if the code below I wrote will even compile.
Obviously I have no way to test it without your data, etc.
If it actually works, it should significantly speed up the parsing of your data.

Code Select Expand



function GetDataToSpaceChr( DestArray() as string, byval nLineNum as long, byval nStartPos as long) as long
   ' Get the characters from the current position up to the first blank space or end of line.
   ' Return the new line parsing offset so the line can continue to be parsed.
   dim as string tempString
   for i as long = nStartPos to len(Array1(nLineNum)) - 1
      if Array1(nLineNum)[i] = 32   ' space character
         exit for
      else
         tempString = tempString & chr(Array1(nLineNum)[i])
      end if   
   NEXT
   DestArray(nLineNum) = tempString
   function = i
END FUNCTION


Sub fill()  '  fills the columns by parsing array1

   Dim ln as String   ' line of code
   Dim k as Integer   ' counter
   Dim t as Integer   ' total chars in ln
   Dim r as String    ' result string if found
   Dim lns as String  ' rhs of line
   Dim kk as Integer
   
   '(130mm diam z 9mm deep)
   'N0001  G90
   'N0002  t32
   '(Begin Next Pass  at -3.000)
   'N0003  M06 S24000
   'N0004  M03
   'N34128  G01 X-17.5362 Y-7.0818 Z-2.3281
   'N34129  G01 X-17.5362 Y-7.0158 Z-2.3324
   'N34130  G01 X-17.5362 Y-6.9498 Z-2.3345
   'N34131  G01 X-17.5362 Y-6.8838 Z-2.3362
   'N34132  G01 X-17.5362 Y-6.8178 Z-2.3400
   'N34133  G01 X-17.5362 Y-6.7518 Z-2.3432
   'N34134  G01 X-17.5362 Y-6.6858 Z-2.3470

   dim as long lb = lbound(Array1)
   dim as long ub = ubound(Array1)
   
   Dim as double t1, t2     ' for timer
   t1 = Timer

   ' Read an process every line in Array1()
   For i as Long = lb To ub

      ' Setting the lines to blank for each arry is not necessary. FreeBASIC already
      ' initializes each string element in the arrays to blank.
   '   arrayn(i)=""
   '   arrayg(i)=""
   '   arrayx(i)=""
   '   arrayy(i)=""
   '   arrayz(i)=""
   '   arrayf(i)=""
   '   arrayo(i)=""
   '   arraya(i)=""
   
      ' Is reassigning the Array(i) string to a temporary string necessary? It
      ' seems like a redundant step.
   '   ln=  Array1(i)  'array1 is populated with g-code lines
   '   lns=ln           'lns is for right hand end of line
   '   t = Len (ln)  'ln is the line being considered

       
      For k = 0 To len(Array1(i)) - 1  ' go through line, character by character
     
         ' Let's use string pointer indexing because it is super cool and much easier
         ' to use that in other BASIC's. It also means we don't have to use expensive
         ' operations line UCASE, LEFT, MID, blah blah blah
         
         ' Format() is a slow FB function as well. Might want to consider not using it
         ' or replace with a faster locally developed version. It appears that your data
         ' is already formated to the correct number of digits so the benefit of Format
         ' seems a little redundant.
         
         ' Also, let's use a Select Case As Const so that a super fast jump table is
         ' created for comparisons.
         
         select case as const Array1(i)[k]
            CASE 78, 110     ' N n
               ' Fill arrayn() with data until we reach the first space of end of line
               k = GetDataToSpaceChr(arrayn(), i, k)               
            CASE 71, 103     ' G g
               k = GetDataToSpaceChr(arrayg(), i, k)               
            CASE 88, 120     ' X x
               k = GetDataToSpaceChr(arrayx(), i, k)               
            CASE 89, 121     ' Y y
               k = GetDataToSpaceChr(arrayy(), i, k)               
            CASE 90, 122     ' Z z
               k = GetDataToSpaceChr(arrayy(), i, k)               
            CASE 65, 97      ' A a
               k = GetDataToSpaceChr(arraya(), i, k)               
            CASE 70, 102     ' F f
               k = GetDataToSpaceChr(arraya(), i, k)               
            CASE 40  ' (  comment to end of line
               k = GetDataToSpaceChr(arrayo(), i, k)               
               exit for    ' exit out of processing the current line and start on next line
         END SELECT
       
      Next


      ' I wasn't sure what the following lines meant so I didn't add any
      ' parsing logic for them?
     
           
   '   'arrayo also holds other codes, except N,G,X,Y,Z,A,F
   '   'check for m, t, etc
   '   kk = InStr (LCase(ln),Any "bcdehijklmopqrstuvw" )
   '   If kk>0 Then arrayo(i)=" "+Right(ln, t-kk+1)
               
   '   'check for special characters       
   '   kk = InStr (ln,Any "!£$%^&*{}:@~#:<>?" )
   '   If kk>0 Then arrayo(i)=" "+Right(ln, t-kk+1)
                 
                 
   Next  ' get next line
       
   
   t2 = Timer   

   ? t1,t2,t2-t1 ,"b4 assign"  'takes 86 seconds to get to here - ignore the following wrt timing
       
   ' Assign the string arrays to the listboxes.
   
   SendMessage( HWND_FRMMAIN_code, VL_SETARRAY, Cast(WPARAM, VarPtr(Array1(0))) , Cast(LPARAM, UBound(Array1)) )
   SendMessage( HWND_FRMMAIN_VLISTn, VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayn(0))) , Cast(LPARAM, UBound(Arrayn)) )
   SendMessage( HWND_FRMMAIN_VLISTg,VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayg(0))) , Cast(LPARAM, UBound(Arrayg)) )
   SendMessage( HWND_FRMMAIN_VLISTx,VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayx(0))) , Cast(LPARAM, UBound(Arrayx)) )
   SendMessage( HWND_FRMMAIN_VLISTy,VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayy(0))) , Cast(LPARAM, UBound(Arrayy)) )
   SendMessage( HWND_FRMMAIN_VLISTz,VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayz(0))) , Cast(LPARAM, UBound(Arrayz)) )
   SendMessage( HWND_FRMMAIN_VLISTf, VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayf(0))) , Cast(LPARAM, UBound(Arrayf)) )
   SendMessage( HWND_FRMMAIN_VLISTo, VL_SETARRAY, Cast(WPARAM, VarPtr(Arrayo(0))) , Cast(LPARAM, UBound(Arrayo)) )
   SendMessage( HWND_FRMMAIN_VLISTa, VL_SETARRAY, Cast(WPARAM, VarPtr(Arraya(0))) , Cast(LPARAM, UBound(Arraya)) )
   

   ' Refresh the listboxes so that the changes can visibly be seen.

   SendMessage( HWND_FRMMAIN_code, VL_REFRESH, 0, 0)     
   SendMessage( HWND_FRMMAIN_VLISTn, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTg, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTx, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTy, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTz, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTf, VL_REFRESH, 0, 0)
   SendMessage( HWND_FRMMAIN_VLISTo, VL_REFRESH, 0, 0)   
   SendMessage( HWND_FRMMAIN_VLISTa, VL_REFRESH, 0, 0)
         
     
   gandf()
   hidew()

   t2 = Timer   

   ? t1,t2,t2-t1 ,"ready to go"      'Note, this time is not significantly greater than time to 'b4 assign'
           
End Sub


[raymw]

Thanks Paul, I'll have a look later (or earlier, it's 2am here...)
The function getdatatospacechr() would need modifying a tad, (maybe to getdatatonotanumber() since there is not always a space where expected (I did mention the code was something like...) lines could be x-55z900.83y0a4524f500(and a comment at the end)  or x  -45A 67.8  and I'm not sure at the moment if there would be a speed improvement over checking every character in the line, but the pointer indexing concept looks useful. I'll try it and see.

(Once this is sorted, I'll be attempting to draw pictures, 3d views etc. That'll be fun...

[Paul Squires]

The function getdatatospacechr() would need modifying a tad, (maybe to getdatatonotanumber() since there is not always a space where expected (I did mention the code was something like...) lines could be x-55z900.83y0a4524f500(and a comment at the end)  or x  -45A 67.8

That should be easy enough... just check for the first non-numeric character or end of line.

...and I'm not sure at the moment if there would be a speed improvement over checking every character in the line, but the pointer indexing concept looks useful.

But your code is already checking every character in the line albeit indirectly by creating temporary strings using RIGHT() in the "Format(Val(Right(lns,(t-(k+1)))),"#.0000") " type of code. The whole idea of the parsing is to eliminate as much as possible the creation of additional strings and utilizing unnecessary PB string commands. String pointer indexing is super fast - much faster than MID(). It is also easier to use than PB's method of creating a byte pointer to the string.