'-------------------------------------------------------------------------------
'File : ArrayFunctions
' mpl © by ERB software
' All rights reserved
'Environment : Access 2000/XP, VB6
'Version : 1.0
'Name : Array Funktionen
'Description : Diverse nützliche Funktionen zu Array's
'Author : Stefan Erb (ERS)
'History : 18.10.2004 - ERS - Creation
'-------------------------------------------------------------------------------
Option Explicit
Option Compare Database
'-------------------------------------------------------------------------------
' Public Methodes
'-------------------------------------------------------------------------------
' /**
' * IsEmptyArray
' * prüft ob ein Array initializiert ist
' * @param Array
' * @return true if Array is not initialized
' */
Public Function IsEmptyArray(ByVal iArray As Variant) As Boolean
Dim Dummy As Long
If IsArray(iArray) Then
'Ggf. Fehler provozieren:
On Error Resume Next
Dummy = LBound(iArray)
'Ergebnis bestimmen:
IsEmptyArray = (Err.Number <> 0)
On Error GoTo 0
Else
Err.Raise 13 'Type mismatch'
End If
End Function
' /**
' * addArray
' * Add Array2 to Array1
' * @param Array1
' * @param Array2
' */
Public Sub addArray(ByRef ioArray As Variant, ByVal iArray As Variant)
Dim i
If Not IsEmptyArray(iArray) Then
For i = 0 To UBound(iArray)
Call pushArray(ioArray, iArray(i))
Next i
End If
End Sub
' /**
' * pushArray
' * add Value to the Array
' * @param Array
' * @param Value
' * @return Ubound of the Array
' */
Public Function pushArray(ByRef ioArray As Variant, ByVal iValue As Variant) As Long
Call ReDimArray(ioArray:=ioArray, oUbound:=pushArray)
ioArray(pushArray) = iValue
End Function
' /**
' * ArrayIndex
' * search the index of a element in a array
' * @param element
' * @param array
' * @return index of the array
' */
Public Function ArrayIndex( _
ByRef iElement As Variant, _
ByRef iArray As Variant _
) As Long
If IsEmptyArray(iArray) Then
ArrayIndex = -1
Exit Function
End If
If IsObject(iElement) Then
'Objekte vergleichen:
For ArrayIndex = LBound(iArray) To UBound(iArray)
If IsObject(iArray(ArrayIndex)) _
Then If iElement Is iArray(ArrayIndex) _
Then Exit Function
Next ArrayIndex
Else
'"Normale" Werte vergleichen:
For ArrayIndex = LBound(iArray) To UBound(iArray)
If Not IsObject(iArray(ArrayIndex)) _
Then If iElement = iArray(ArrayIndex) _
Then Exit Function
Next ArrayIndex
End If
'Kein Treffer:
ArrayIndex = LBound(iArray) - 1
End Function
' /**
' * ReDimArray
' * redim a array
' * @param array (ByRef)
' * @param step
' * @param Ubound of the Array
' * @return new array
' */
Public Function ReDimArray( _
ByRef ioArray As Variant, _
Optional ByVal iStep As Long = 1, _
Optional ByRef oUbound As Long) _
As Variant
If IsEmptyArray(ioArray) Then
ReDim ioArray(iStep - 1)
ElseIf UBound(ioArray) + iStep > -1 Then
ReDim Preserve ioArray(UBound(ioArray) + iStep)
End If
ReDimArray = ioArray
oUbound = UBound(ioArray)
End Function
' /**
' * ArrayQuickSort
' * sort the elements of a array
' http://www.vbarchiv.net/archiv/tipp_details.php?pid=372
' * @param array (ByRef)
' * @param start
' * @param end
' */
Public Sub ArrayQuickSort(ByRef ioArray As Variant, _
Optional ByVal iStart As Variant, _
Optional ByVal iEnd As Variant)
' Wird die Bereichsgrenze nicht angegeben,
' so wird das gesamte Array sortiert
If IsMissing(iStart) Then iStart = LBound(ioArray)
If IsMissing(iEnd) Then iEnd = UBound(ioArray)
Dim i As Long
Dim j As Long
Dim h As Variant
Dim x As Variant
i = iStart: j = iEnd
x = ioArray((iStart + iEnd) / 2)
' Array aufteilen
Do
While (ioArray(i) < x): i = i + 1: Wend
While (ioArray(j) > x): j = j - 1: Wend
If (i <= j) Then
' Wertepaare miteinander tauschen
h = ioArray(i)
ioArray(i) = ioArray(j)
ioArray(j) = h
i = i + 1: j = j - 1
End If
Loop Until (i > j)
' Rekursion (Funktion ruft sich selbst auf)
If (iStart < j) Then ArrayQuickSort ioArray, iStart, j
If (i < iEnd) Then ArrayQuickSort ioArray, i, iEnd
End Sub