Option Compare Database
Option Explicit

'CLASS Lijst (dutch for 'list')
'USES  StringObj
'
'the objects stored are strings, but can contain fields separated by tabs

Dim items() As String, curPtr As Integer, bottom As Integer
Dim founds As New Stack, cLastSearch As String

Sub AddItem(cIt As String)
'simple add routine
   bottom = bottom + 1
   ReDim Preserve items(bottom)
   items(bottom) = cIt
End Sub

Property Get size()
'returns number of items in object
   size = bottom
End Property

Property Get Item(ByVal nSeq As Integer) As String
'returns an item of the object of which you know the internal sequence no.
   Item = items(nSeq)
End Property

Property Let Item(ByVal nSeq As Integer, ByVal cVal As String)
'changes an item of the object of which you know the internal sequence no.
   items(nSeq) = cVal
End Property

Property Get curItem() As String
'returns the 'current' item
   If curPtr = 0 Then
      curItem = ""
   Else
      curItem = items(curPtr)
   End If
End Property

Property Let curItem(ByVal cVal As String)
'changes the 'current' item
   items(curPtr) = cVal
End Property

Private Sub Class_Initialize()
   bottom = 0
   curPtr = 0
   cLastSearch = ""
   founds.pull
End Sub

Function searchpath() As String
'for debugging: dump the search path
   searchpath = founds.dump
End Function

Sub readFile(ByVal cFile As String)
'fill an object from a file
Dim nFile As Integer
   nFile = FreeFile
   Open cFile For Input As nFile
   bottom = 1
   Do While Not EOF(nFile)
      ReDim Preserve items(bottom)
      Input #nFile, items(bottom)
      bottom = bottom + 1
   Loop
   curPtr = 1
   Close nFile
End Sub

Function findItem(ByVal cWhat As String, Optional vFrom As Variant) As Boolean
'*binary search* can do, optionally, only second part of the list
'algorithm:
'
'top :=1
'bot := @listlen
'
'exit := false
' while not exit
'  =================================================
'  |mid := (top+bot) div 2
'  |___(mid) = searchitem?__________________________
'  |NO                           |YES
'  |___< searchitem?_____________|return true
'  |YES           |NO            |curPtr := mid   
'  |top:=mid      |bot:=mid      |exit := true
'  |=============================|
'  |___bot-top > 1?______________|
'  |YES           |NO            |
'  |              |exit := true  |
'  |              |return false  |
'===================================================

Dim nTop As Integer, nBot As Integer, nMid As Integer
Dim nWhat As Integer, it As String, bExit As Boolean
   nWhat = Len(cWhat)
   If IsMissing(vFrom) Then
      nTop = 1
   Else
      nTop = vFrom
   End If
   nBot = bottom
   
   Do While Not bExit
      nMid = Int((nTop + nBot) / 2)
      it = Left(items(nMid), nWhat)
      If it = cWhat Then
         findItem = True
         curPtr = nMid
         bExit = True
      Else
         If it < cWhat Then
            nTop = nMid
         Else
            nBot = nMid
         End If
         If nBot - nTop < 2 Then
            bExit = True
            findItem = False
         End If
      End If
   Loop
End Function

Function findFirst(ByVal cWhat As String, Optional vFrom As Variant) As Boolean
'since findItem returns any match, check if it is really the first
Dim bRes As Boolean
   bRes = findItem(cWhat, vFrom)
   If bRes Then
      Do While curPtr > 1 And Left(items(curPtr), Len(cWhat)) = cWhat
         curPtr = curPtr - 1
      Loop
      If Left(items(curPtr), Len(cWhat)) <> cWhat Then
         curPtr = curPtr + 1
      End If
   End If
   findFirst = bRes
End Function

Function findNext(ByVal cWhat As String) As Boolean
'next means here: the search term has expanded or shrunk(en?)
' this is especially useful when called, say, from a Changed event of a text box
'
'algorithm:
'if previous search:
'  compare with previous search cwhat
'  if longer
'     start (sequential?) search at curptr
'     if found
'        store curptr in stack
'     fi
'  else
'     return previous value from stack
'  fi
'else
'  do a findfirst
'  if found
'     store curptr in stack
'  fi
'fi
'write search string

Dim bRes As Boolean, nPtr As Integer
   If Not founds.isEmpty Then
      If Len(cWhat) > Len(cLastSearch) Then
         founds.push curPtr
         If findFirst(cWhat, curPtr) Then
            findNext = True
         Else
            findNext = False
            curPtr = 0
         End If
      Else
         If Len(cWhat) < Len(cLastSearch) Then
            nPtr = founds.pull
            If nPtr > 0 Then
               curPtr = nPtr
               findNext = True
            Else
               findNext = False
            End If
            If founds.isEmpty Then curPtr = 1
         Else
            'assertion failed!
            findNext = False
         End If
      End If
   Else
      If findFirst(cWhat) Then
         findNext = True
         founds.push curPtr
      Else
         findNext = False
         founds.push 0
      End If
   End If
   cLastSearch = cWhat
End Function

Sub setFirstCol(ByVal nOrd As Integer, ByVal cSep As String)
'change internal field order of all items in object:
'nOrd-th column becomes first
Dim i As Integer, nPos As Integer
   'checkInvalCol
   If nOrd < 2 Then Exit Sub
   If bottom < 1 Then Exit Sub
   If getColStart(items(1), nOrd, cSep) = 0 Then Exit Sub
   'with all items: swapcol
   For i = 1 To bottom - 1
      items(i) = swapCol(items(i), nOrd, cSep)
   Next
End Sub

Private Function swapCol(ByVal cString As String, ByVal nCol As Integer, ByVal cSep As String) As String
'Pull nCol-th column to the front of the item
'(read-only function)
Dim cRes As New StringObj, i As Integer, cTrans As New StringObj
   cTrans.init cString, cSep
   For i = 1 To nCol - 1
      cRes.Add cTrans.Remove
   Next
   cRes.Ins cTrans.Remove
   cRes.Add cTrans.value
   swapCol = cRes.value
End Function

Private Function getColStart(ByVal cItem As String, ByVal nCol As Integer, ByVal cSep As String) As Integer
'returns character count of column start
'what?
'if the 4th column (of the item supplied - this assumes some sort of tab expanding to spaces)
'  starts at character 23, returns 23 when nCol is 4
'Well, what use is that? In this class, it is only called to see if so many columns exist.
Dim i As Integer, nPos As Integer
   nPos = 0
   For i = 1 To nCol
      nPos = InStr(nPos + 1, cItem, cSep)
      If nPos = 0 Then Exit For
   Next
   getColStart = nPos
End Function

Sub sort()
'sorts the object in ascending order

'algorithm: shuffle sort
'compare n, n+1
'if wrong order
'  move n+1 up until correct
Dim h As Integer, i As Integer, j As Integer, hold As String
   For i = 1 To bottom - 2
      If items(i) > items(i + 1) Then
         h = i
         hold = items(i + 1)
         Do
            h = h - 1
         Loop Until h = 0 Or items(h) < hold
         h = h + 1 'h wijst nu op eerstvolgend item
         For j = i To h Step -1
            items(j + 1) = items(j) 'push block down
         Next
         items(h) = hold
      End If
   Next
End Sub

Sub Top()
'sets the 'current' item to first
   If bottom < 1 Then Exit Sub
   curItem = 1
End Sub

Sub WriteListBox(myList As ListBox, Optional maxrows As Variant)
'modifies a given listbox so that it contains the (value of the) object afterwards
Dim cRes As New StringObj, cTrans As New StringObj, nPos As Integer, nCount As Integer
   If bottom = 0 Then Exit Sub
   myList.RowSourceType = "Value list"
'THIS ASSUMES THAT YOUR SEPARATOR CHARACTER IS A TAB
   myList.ColumnCount = countCols(Chr(9))
   nCount = 1
   If IsMissing(maxrows) Then maxrows = bottom
   nPos = curPtr
   cRes.init "", ";"
   Do
      cTrans.init items(nPos), Chr(9)
      Do While Not cTrans.isEmpty
         cRes.Add cTrans.Remove
      Loop
      nCount = nCount + 1
      nPos = nPos + 1
   Loop Until nCount = maxrows Or nPos = bottom
   myList.RowSource = Left(cRes.value, 1024)
End Sub

Private Function countCols(ByVal cSep As String) As Integer
'returns the number of fields as separated by supplied character (can be more than 1, yes)
Dim nRes As Integer, nPos As Integer
   nRes = 0
   nPos = 0
   Do
      nPos = InStr(nPos + 1, items(1), cSep)
      nRes = nRes + 1
   Loop Until nPos = 0
   countCols = nRes
End Function