Class TableJar %REM Author: Jens Seiler Date: 2006/10/18 http://www.jens-seiler.de This class implements a 2-dimensional table which grows dynamically and has certain features as removing/inserting rows and sorting the table by a column. This implementation has not yet been fully tested. So use it with caution! %END REM Private retNotValue As Integer Private lastRowIndex As Integer Private rows() As Row 'Private something As Variant Sub New retNotValue = True lastRowIndex% = -1 End Sub 'New Property Get Count As Integer Count = lastRowIndex% + 1 End Property ' Count Public Sub useNothingAsReturn(retNotValue2 As Variant) If (retNotValue2) Then retNotValue = True Else retNotValue = False End If End Sub ' writes columns into a document Public Sub writeIntoDoc(doc As NotesDocument, columnFieldNames As Variant) Dim column As Integer Dim row As Integer Dim tempColumn As Variant Redim tempColumn(0 To lastRowIndex%) For column% = Lbound(columnFieldNames) To Ubound(columnFieldNames) For row% = 0 To lastRowIndex% tempColumn(row%) = getValue(row%, column%) Next row% Call doc.replaceItemValue(columnFieldNames(column%), tempColumn) Next column% End Sub ' reads columns from a document Public Sub readFromDoc(doc As NotesDocument, columnFieldNames As Variant) Dim column As Integer Dim row As Integer Dim rows As Integer Dim tempColumn As Variant For column% = Lbound(columnFieldNames) To Ubound(columnFieldNames) tempColumn = doc.getItemValue(columnFieldNames(column%)) rows% = Ubound(tempColumn) For row% = 0 To rows% Call setValue(row%, column%, tempColumn(row%)) Next row% Next column% End Sub Public Function getValue(row As Integer, column As Integer) As Variant On Error Goto ErrorGetValue Dim rowObj As Row Set rowObj = rows(row%) If (Datatype(rowObj.getValue(column%)) >= 34) Then ' >= 34: object, list or array reference Set getValue = rowObj.getValue(column%) Else getValue = rowObj.getValue(column%) End If Exit Function ErrorGetValue: If (Err()) = 91 Then ' empty row / column = return nothing If (retNotValue) Then Set getValue = Nothing Else getValue = "" End If End If If (Err()) = 9 Then ' empty row / column = return nothing If (retNotValue) Then Set getValue = Nothing Else getValue = "" End If End If Exit Function Msgbox Err() & " " & Error$ & " " & Erl End Function 'getValue Public Sub setValue(row As Integer, column As Integer, value As Variant) If (row% > lastRowIndex%) Then lastRowIndex% = row% Redim Preserve rows(0 To lastRowIndex%) End If Dim rowObj As Row Set rowObj = rows(row%) If (rowObj Is Nothing) Then Set rowObj = New Row End If Call rowObj.setValue(column, value) Set rows(row%) = rowObj End Sub 'setValue Private Sub swap(row1 As Integer, row2 As Integer) Dim tempRow As Row Set tempRow = rows(row1%) Set rows(row1%) = rows(row2%) Set rows(row2%) = tempRow End Sub 'swap Public Sub deleteRow(row As Integer) Dim i As Integer If (row% <= lastRowIndex%) Then If (lastRowIndex% = 0) Then lastRowIndex% = -1 Erase rows Exit Sub End If For i% = row% To lastRowIndex% - 1 Call swap(i%, i%+1) Next lastRowIndex% = lastRowIndex% - 1 Redim Preserve rows(0 To lastRowIndex%) End If End Sub 'deleteRow Public Function findRow(searchValue As Variant, column As Integer) As Integer ' finds the first row with searchValue in the given column, returns -1 if searchValue not found Dim i As Integer For i% = 0 To lastRowIndex% If (searchValue = getValue(i%, column%)) Then findRow = i% Exit Function End If Next findRow% = -1 End Function Public Sub insertRow(row As Integer) ' inserts an empty row before the given one and moves up all following rows lastRowIndex% = lastRowIndex% + 1 Redim Preserve rows(0 To lastRowIndex%) Dim i As Integer For i% = lastRowIndex% To row% + 1Step -1 Call swap (i%, i% - 1) Next End Sub 'insertRow Public Sub sort(keyColumn As Integer) Dim i As Integer For i% = (lastRowIndex%+1) / 2 To 1 Step -1 Call reheap(keyColumn, i%, lastRowIndex% + 1) Next For i% = (lastRowIndex% + 1) To 2 Step -1 Call swap(0, i% - 1) Call reheap(keyColumn%, 1, i% - 1) Next End Sub 'sort Private Sub reheap(keyColumn As Integer, pos As Integer, size As Integer) If ( pos% > size%/2) Then Exit Sub If ( pos% = size%/2) Then If ( rows(pos% - 1).getValue(keyColumn%) >= rows((2*pos%) -1).getValue(keyColumn%) ) Then Exit Sub Else Call swap(pos% - 1, (2*pos%) - 1) End If End If If ( pos% < size%/2) Then Dim l As Integer If ( rows((2*pos%) - 1).getValue(keyColumn%) >= rows(2*pos%).getValue(keyColumn%) ) Then l% = 2*pos% Else l% = 2*pos% + 1 End If If ( rows(pos% - 1).getValue(keyColumn%) >= rows(l% -1).getValue(keyColumn%) ) Then Exit Sub Else Call swap(pos% - 1, l% - 1) Call reheap(keyColumn%, l%, size%) End If End If End Sub 'reheap End Class ' TableJar Class Row Private lastColumnIndex As Integer Private row() As Variant Sub New lastColumnIndex% = 0 Redim row(0 To lastColumnIndex%) End Sub 'New Public Function getValue(column As Integer) As Variant If (column > lastColumnIndex) Then Set getValue = Nothing Exit Function End If If ( Datatype(row(column%)) >= 34 ) Then ' >= 34: object, list or array reference Set getValue = row(column%) Else getValue = row(column%) End If End Function 'getValue Public Sub setValue(column As Integer, value As Variant) If (column% > lastColumnIndex%) Then lastColumnIndex% = column% Redim Preserve row(0 To lastColumnIndex) End If If (Datatype(value) >= 34) Then ' >= 34: object, list or array reference Set row(column%) = value Else row(column%) = value End If End Sub 'setValue End Class 'Row