ABOUT Visual Basic - das Webmagazin: Unendliche Arrays (Klasse)

ABOUT Visual Basic Programmieren Programmierung Download Downloads Tips & Tricks Tipps & Tricks Know-How Praxis VB VBA Visual Basic for Applications VBS VBScript Scripting Windows ActiveX COM OLE API ComputerPC Microsoft Office Microsoft Office 97 Office 2000 Access Word Winword Excel Outlook Addins ASP Active Server Pages COMAddIns ActiveX-Controls OCX UserControl UserDocument Komponenten DLL EXE

(-hg)

Natürlich kann es keine tatsächlich unendlich großen Arrays geben. Jeder Arbeitsspeicher ist letztlich endlich, selbst bei noch so geräumigen Auslagerungsmöglichkeiten. So ist es zwar theoretisch möglich, beispielsweise ein Array mit drei Dimensionen anzulegen, wobei jede Dimension 65.536 Elemente enthält. Doch dürften PCs mit derartig großem Arbeitsspeicher oder Festplatten zur Auslagerung ziemlich rar sein.

Allerdings können Sie trotzdem zwei Grenzen sprengen. Erstens können Sie, wenn es denn sein müsste, durchaus die in Visual Basic gegebene Grenze von 60 Dimensionen locker überschreiten. Zweitens kann jede dieser Dimensionen beliebig viele Elemente enthalten - beispielsweise 999.999.999.999.999 Elemente.

Der Trick dahinter besteht zum einen lediglich darin, nicht gleich für alle möglichen Elemente in allen Dimensionen von vornherein Speicherplatz zu reservieren. Die einzige Grenze setzt dann nur noch der tatsächlich verfügbare Arbeits- samt Auslagerungsspeicher. Zum anderen besteht der Trick darin, verschachtelte Collections und zu String-Schlüsseln konvertierte Indices zu verwenden.

Der Grundgedanke ist folgender, etwa bei einem solchen Array mit drei Dimensionen, in das zum Beispiel eine Element unter den Indices (123, 456, 789) eingefügt werden soll:

Eine Collection bildet die erste Dimension, die zugleich das gesamte Array repräsentiert. In diese wird unter dem (String-)Schlüssel "123" eine zweite Collection eingefügt. In diese wird nun wiederum eine weitere Collection unter dem Schlüssel "456" eingefügt. Und in diese letzte Collection wird schließlich das abzulegende Element (beispielsweise der String "Hallo") unter dem Schlüssel "789" eingefügt.

Dim nDim1 As Collection
Dim nDim2 As Collection
Dim nDim3 As Collection
Dim nElement As String

nElement = "Hallo"
Set nDim1 = New Collection
Set nDim2 = New Collection
Set nDim3 = New Collection
nDim1.Add nDim2, CStr(123)
nDim2.Add nDim3, CStr(456)
nDim3.Add Element, CStr(789)

Das Auslesen aus dem "Array" nDim1 geht dann so vonstatten:

Dim nDim2 As Collection
Dim nDim3 As Collection
Dim nElement As String

Set nDim2 = nDim1(CStr(123))
Set nDim3 = nDim2(CStr(456))
nElement = nDim3(CStr(789))

Solange Sie jedoch zunächst noch nummerische Werte als Indices verwenden, bleibt natürlich noch die Grenze der möglichen nummerischen Datentypen bestehen. Verwenden Sie jedoch gleich von vornherein Strings, die ja eine recht große Anzahl an Ziffern enthalten können, wird diese Beschränkung aufgehoben. Gehen Sie noch einen gedanklichen Schritt weiter: Sie können auch gleich Strings mit beliebigem Inhalt als Schlüssel statt irgendwelcher Zahlen als Indices verwenden.

Der Code-Aufwand ist auch nicht gerade unbeträchtlich (siehe oben). Daher ist es naheliegend, die Angelegenheit in die zur Repräsentation mehrerer Dimensionen verschachtelbare Klasse "Dimension" zu packen.

Die Verwendung dieser Klasse ist wirklich einfach. Sie legen eine Instanz der Klasse an und legen über die Eigenschaft Dimensions einmalig (und nachträglich nicht mehr änderbar) die Anzahl der Dimensionen fest:

Dim mArray As Dimension

Set mArray = New Dimension
mArray.Dimensions = 3

Ein Element fügen Sie folgendermaßen ein:

mArray.Item(123, 456, 789) = "Hallo"

bzw.

mArray(123, 456, 789) = "Hallo"

Und das Auslesen geht einfacherweise so:

Debug.Print mArray.Item(123, 456, 789)

bzw.

Debug.Print mArray(123, 456, 789)

Gelöscht wird ein Element über die Remove-Methode:

mArray.Remove 123, 456, 789

Dabei wird das gelöschte Element auch zurückgegeben:

Debug.Print mArray.Remove(123, 456, 789)

Schließlich können Sie über die Methode Clear noch den gesamten Inhalt löschen.

Geben Sie weniger oder mehr Indices an, als Sie zuvor beim Instanzieren als Anzahl der Dimensionen angegeben haben, werden abfangbare Laufzeitfehler ausgelöst.

Ausnahmen von dieser Regel bilden die Eigenschaften Count und Dimension. Über Count können Sie für jede Dimension ermitteln, wie viele Elemente jeweils bereits belegt sind:

Debug.Print mArray.Count(123)
Debug.Print mArray.Count(123, 456)
Debug.Print mArray.Count(123, 456, 789)

Die Eigenschaft Dimension liefert hingegen die jeweilige Dimension selbst.

Dim nDimension As Dimension

Set nDimension = mArray(123)
Set nDimension = mArray(123, 456) 
Set nDimension = mArray(123, 456, 789)

Geben Sie nur einen oder gar keinen Index an, wird das Dimensions-Objekt zurückgegeben, das das Array selbst repräsentiert. Die zurückgegebenen Dimension-Objekte geben in ihrer Dimensions-Eigenschaft die entsprechend der Tiefe verringerte Anzahl der Dimensionen zurück.

Ebenso ist eine Iteration durch die Elemente jeder Dimensions-Ebene in For...Each-Schleifen möglich, auch verschachtelt etwa zum Auflisten aller enthaltenen Elemente:

Dim nDim2 As Dimension
Dim nDim3 As Dimension
Dim nElement As String

For Each nDim1 In mArray
  For Each nDim2 in nDim1
    For Each nElement in nDim2
      Debug.Print nElement
    Next
  Next
Next

In dem Array können Sie Elemente jedes beliebigen Variant-Datentyps ablegen, ausgenommen sind Objekte. Dafür gibt als eigene Variante die Klasse DimensionObj. Dies ist notwendig, da Objekte mit Set einer Variablen oder einem Rückgabewert zugewiesen werden müssen - wegen der Verschachtelung müssen diese Zuweisungen im internen Code eindeutig behandelbar sein.

Ein paar Unterschiede zu normalen Arrays gibt es allerdings. Es gibt keine Unter- und Obergrenzen (LBound und UBound). Und die Elemente können nicht mehr in nummerischer Reihenfolge durchlaufen werden, sondern nur in der Reihenfolge, in der sie eingefügt worden sind. Es ist aber denkbar, dass Sie diese Features mit (jedoch vielleicht nicht unerheblichem) zusätzlichem Aufwand nachrüsten könnten.

Arrays dieser Art eignen sich also eher (und damit auch bestens) zur Verwaltung von großen Tabellen (zwei Dimensionen) und Gittern (drei Dimensionen).

Hier nun der komplette Code der Klasse Dimension. Den leicht abweichenden Code der Variante DimensionObj finden Sie im Download-Paket zu diesem Artikel.

Private mItems As Collection
Private mDimensions As Integer

Public Enum DimensionErrorConstants
  dimErrDimensionsNotSet = vbObjectError + 10001
  dimErrSubscriptOutOfRange = vbObjectError + 10002
  dimErrInvalidIndexVarType = vbObjectError + 10003
  dimErrInvalidDimension = vbObjectError + 10004
  dimErrAlreadyDimensioned = vbObjectError + 10005
  dimErrItemNotFound = vbObjectError + 10006
  dimErrCannotInsertObject = vbObjectError + 10007
End Enum
  
Public Property Get Count(ParamArray Index() As Variant) As Long
  Dim nItem As Dimension
  Dim nThisIndex As String
  Dim nThisArray As Variant
  Dim nSubIndices() As Variant
  Dim i As Integer
  
  Const kErrSource = "Dimension.Count"
  
  If mDimensions = 0 Then
    Err.Raise dimErrDimensionsNotSet, kErrSource
  End If
  Select Case UBound(Index)
    Case Is = -1
      Count = mItems.Count
    Case Is > mDimensions - 1, Is < -1
      Err.Raise dimErrSubscriptOutOfRange, kErrSource
    Case Else
      If IsArray(Index(0)) Then
        nThisArray = Index(0)
      Else
        nThisArray = Index
      End If
      On Error Resume Next
      nThisIndex = CStr(nThisArray(0))
      If Err.Number Then
        On Error GoTo 0
        Err.Raise dimErrInvalidIndexVarType, kErrSource
      Else
        Set nItem = mItems(nThisIndex)
        If Err.Number = 0 Then
          Select Case UBound(nThisArray) + 1
            Case 1
              Count = nItem.Count
            Case 2 To mDimensions - 1
              ReDim nSubIndices(0 To UBound(nThisArray) - 1)
              For i = 1 To UBound(nThisArray) + 1
                nSubIndices(i - 1) = nThisArray(i)
              Next 'i
              On Error GoTo 0
              Count = nItem.Count(nSubIndices)
          End Select
        End If
      End If
  End Select
End Property

Public Property Get Dimension(ParamArray Index() As Variant) _
 As Dimension

  Dim nItem As Dimension
  Dim nThisIndex As String
  Dim nThisArray As Variant
  Dim nSubIndices() As Variant
  Dim i As Integer
  
  Const kErrSource = "Dimension.Dimension"
  
  If mDimensions = 0 Then
    Err.Raise dimErrDimensionsNotSet, kErrSource
  End If
  Select Case UBound(Index)
    Case Is = -1
      Set Dimension = Me
    Case Is > mDimensions - 1, Is < -1
      Err.Raise dimErrSubscriptOutOfRange, kErrSource
    Case Else
      If IsArray(Index(0)) Then
        nThisArray = Index(0)
      Else
        nThisArray = Index
      End If
      On Error Resume Next
      nThisIndex = CStr(nThisArray(0))
      If Err.Number Then
        On Error GoTo 0
        Err.Raise dimErrInvalidIndexVarType, kErrSource
      Else
        Set nItem = mItems(nThisIndex)
        If Err.Number = 0 Then
          Select Case UBound(nThisArray) + 1
            Case 1
              Set Dimension = nItem
            Case 2 To mDimensions - 1
              ReDim nSubIndices(0 To UBound(nThisArray) - 1)
              For i = 1 To UBound(nThisArray) + 1
                nSubIndices(i - 1) = nThisArray(i)
              Next 'i
              On Error GoTo 0
              Set Dimension = nItem.Dimension(nSubIndices)
          End Select
        End If
      End If
  End Select
End Property

Public Property Get Dimensions() As Integer
  Dimensions = mDimensions
End Property

Public Property Let Dimensions(New_Dimensions As Integer)
  Const kErrSource = "Dimension.Dimensions"
  
  If mDimensions = 0 Then
    Select Case New_Dimensions
      Case Is > 0
        mDimensions = New_Dimensions
      Case Else
        Err.Raise dimErrInvalidDimension, kErrSource
    End Select
  Else
    Err.Raise dimErrAlreadyDimensioned, kErrSource
  End If
End Property

Public Property Get Item(ParamArray Index() As Variant) As Variant
  Dim nItem As Variant
  Dim nThisIndex As String
  Dim nThisArray As Variant
  Dim nSubIndices() As Variant
  Dim i As Integer
  
  Const kErrSource = "Dimension.Item[Get]"
  
  If mDimensions = 0 Then
    Err.Raise dimErrDimensionsNotSet, kErrSource
  End If
  If UBound(Index) < 0 Then
    Err.Raise dimErrSubscriptOutOfRange, kErrSource
  Else
    If IsArray(Index(0)) Then
      nThisArray = Index(0)
    Else
      nThisArray = Index
    End If
    Select Case UBound(nThisArray) + 1
      Case 1 To mDimensions
      Case Else
        Err.Raise dimErrSubscriptOutOfRange, kErrSource
    End Select
    On Error Resume Next
    nThisIndex = CStr(nThisArray(0))
    If Err.Number Then
      On Error GoTo 0
      Err.Raise dimErrInvalidIndexVarType, kErrSource
    Else
      Set nItem = mItems(nThisIndex)
      If Err.Number Then
        Err.Clear
        Item = mItems(nThisIndex)
        If Err.Number Then
          On Error GoTo 0
          Err.Raise dimErrItemNotFound, kErrSource
        End If
        Exit Property
      End If
      If UBound(nThisArray) > 0 Then
        ReDim nSubIndices(0 To UBound(nThisArray) - 1)
        For i = 1 To UBound(nThisArray)
          nSubIndices(i - 1) = nThisArray(i)
        Next 'i
        On Error GoTo 0
        Select Case UBound(nThisArray) + 1
          Case Is < mDimensions
            Set Item = nItem.Item(nSubIndices)
          Case Else
            Item = nItem.Item(nSubIndices)
        End Select
      Else
        Set Item = nItem
      End If
    End If
  End If
End Property

Public Property Let Item(ParamArray Index() As Variant, _
 New_Item As Variant)

  Dim nSubItem As Variant
  Dim nThisIndex As String
  Dim nThisArray As Variant
  Dim nSubIndices() As Variant
  Dim i As Integer
  
  Const kErrSource = "Dimension.Item[Let]"
  
  If mDimensions = 0 Then
    Err.Raise dimErrDimensionsNotSet, kErrSource
  End If
  If IsObject(New_Item) Then
    Err.Raise dimErrCannotInsertObject, kErrSource
  End If
  If UBound(Index) < 0 Then
    Err.Raise dimErrSubscriptOutOfRange, kErrSource
  Else
    If IsArray(Index(0)) Then
      nThisArray = Index(0)
    Else
      nThisArray = Index
    End If
    If mDimensions <> UBound(nThisArray) + 1 Then
      Err.Raise dimErrSubscriptOutOfRange, kErrSource
    End If
    On Error Resume Next
    nThisIndex = CStr(nThisArray(0))
    If Err.Number Then
      On Error GoTo 0
      Err.Raise dimErrInvalidIndexVarType, kErrSource
    Else
      If UBound(nThisArray) > 0 Then
        Set nSubItem = mItems(nThisIndex)
        If Err.Number Then
          Err.Clear
          If UBound(nThisArray) > 0 Then
            Set nSubItem = New Dimension
            nSubItem.Dimensions = UBound(nThisArray)
            mItems.Add nSubItem, nThisIndex
            ReDim nSubIndices(0 To UBound(nThisArray) - 1)
            For i = 1 To UBound(nThisArray)
              nSubIndices(i - 1) = nThisArray(i)
            Next 'i
            On Error GoTo 0
            nSubItem.Item(nSubIndices) = New_Item
          End If
        Else
          If UBound(nThisArray) > 0 Then
            ReDim nSubIndices(0 To UBound(nThisArray) - 1)
            For i = 1 To UBound(nThisArray)
              nSubIndices(i - 1) = nThisArray(i)
            Next 'i
            On Error GoTo 0
            nSubItem.Item(nSubIndices) = New_Item
          End If
        End If
      Else
        mItems.Add New_Item, nThisIndex
        If Err.Number Then
          mItems.Remove nThisIndex
          mItems.Add New_Item, nThisIndex
        End If
      End If
    End If
  End If
End Property

Public Sub Clear()
  Set mItems = New Collection
End Sub

Public Function Remove(ParamArray Index() As Variant) As Variant
  Dim nItem As Variant
  Dim nThisIndex As String
  Dim nThisArray As Variant
  Dim nSubIndices() As Variant
  Dim i As Integer
  
  Const kErrSource = "Dimension.Remove"
  
  If mDimensions = 0 Then
    Err.Raise dimErrDimensionsNotSet, kErrSource
  End If
  If UBound(Index) < 0 Then
    Err.Raise dimErrSubscriptOutOfRange, kErrSource
  Else
    If IsArray(Index(0)) Then
      nThisArray = Index(0)
    Else
      nThisArray = Index
    End If
    If mDimensions <> UBound(nThisArray) + 1 Then
      Err.Raise dimErrSubscriptOutOfRange, kErrSource
    End If
    On Error Resume Next
    nThisIndex = CStr(nThisArray(0))
    If Err.Number Then
      On Error GoTo 0
      Err.Raise dimErrInvalidIndexVarType, kErrSource
    Else
      Set nItem = mItems(nThisIndex)
      If Err.Number Then
        Err.Clear
        Remove = mItems(nThisIndex)
        If Err.Number Then
          On Error GoTo 0
          Err.Raise dimErrItemNotFound, kErrSource
        Else
          mItems.Remove nThisIndex
        End If
        Exit Function
      End If
      ReDim nSubIndices(0 To UBound(nThisArray) - 1)
      For i = 1 To UBound(nThisArray)
        nSubIndices(i - 1) = nThisArray(i)
      Next 'i
      On Error GoTo 0
      Remove = nItem.Remove(nSubIndices)
      If nItem.Count = 0 Then
        mItems.Remove nThisIndex
      End If
    End If
  End If
End Function

Public Function NewEnum() As IUnknown
  Set NewEnum = mItems.[_NewEnum]
End Function

Private Sub Class_Initialize()
  Set mItems = New Collection
End Sub

Die Klassen Dimension und DimensionObj (dimension.zip - ca. 3,4 KB)

					Copyright © 1999 - 2023 Harald M. Genauck, ip-pro gmbh / Impressum