Since there's so many often badly written (or incomplete) Array-check-routines floating around,
here's a Drop-In-Module (you might name it e.g. modArrInfo.bas).
With that, you can then perform complete Array-instrospection, like shown in the Test-Formcode below:
Ok, and here the Code for the Drop-In-Module
Have fun with it (plus safer ArrayHandling) ;)
Olaf
here's a Drop-In-Module (you might name it e.g. modArrInfo.bas).
With that, you can then perform complete Array-instrospection, like shown in the Test-Formcode below:
Code:
Option Explicit
Private Sub Form_Load()
Dim Arr() As String
Arr = Split("") 'check with an intialized, but not yet redimmed Array (comment out to test an un-initialized case)
'ReDim Arr(1 To 5, 0 To 0) 'to re-check the calls below with a 2D-redimmed array
Debug.Print "TypeName:", " "; TypeName(Arr)
Debug.Print "ArrPtrSym:", ArrPtrSym(Arr)
Debug.Print "ArrPtrSaf:", ArrPtrSaf(Arr)
Debug.Print "ArrPtrDat:", ArrPtrDat(Arr)
Debug.Print "ArrDimens:", ArrDimens(Arr)
Debug.Print "ArrLBound:", ArrLBound(Arr)
Debug.Print "ArrUBound:", ArrUBound(Arr)
Debug.Print "ArrLength:", ArrLength(Arr) '<- this is the recommended call, when you check for the necessity of redimensioning
Debug.Print "ArrElemSz:", ArrElemSz(Arr)
Debug.Print "ArrMemory:", ArrMemory(Arr); ", ...and the Struct itself:"; ArrMemory(Arr, True) - ArrMemory(Arr)
End SubCode:
Option Explicit 'SafeArray-Helpers O. Schmidt
'UDT-Arrays have to use the following call for symbol-ptr retrieval
'(one should pass the return-value of this function, and not the UDT-array directly)
Public Declare Function ArrPtrUdt& Lib "msvbvm60" Alias "VarPtr" (Arr() As Any)
Private Declare Function ArrPtr& Lib "msvbvm60" Alias "__vbaRefVarAry" (Arr)
Private Declare Function DeRef& Lib "msvbvm60" Alias "GetMem4" (ByVal pSrc&, pRes&)
Private Declare Function SafeArrayGetDim% Lib "oleaut32" (ByVal pSA&)
Private Declare Function SafeArrayGetElemsize% Lib "oleaut32" (ByVal pSA&)
Private Declare Function SafeArrayGetLBound& Lib "oleaut32" (ByVal pSA&, ByVal nDim%, pRes&)
Private Declare Function SafeArrayGetUBound& Lib "oleaut32" (ByVal pSA&, ByVal nDim%, pRes&)
Private Declare Function SafeArrayAccessData& Lib "oleaut32" (ByVal pSA&, pData&)
Private Declare Function SafeArrayUnaccessData& Lib "oleaut32" (ByVal pSA&)
'All of the functions below will throw no Errors when used with normal-Arrays (which can be passed directly)
'The same routine-behaviour is ensured also with UDT-Arrays, but then with one caveat:
'You need one additional, indirect FuncCall (using the API-call which was defined Public above)
'Example: Dim Points() As PointAPI
' If ArrLength(ArrPtrUdt(Points)) Then 'the UDT-Arr is already redimmed
Function ArrPtrSym(Arr) As Long 'returns the Symbol-Ptr of the Arr-Variable (0 when not initialized)
If IsArray(Arr) Then ArrPtrSym = ArrPtr(Arr) Else ArrPtrSym = Arr
End Function
Function ArrPtrSaf(Arr) As Long 'returns a Ptr to the SafeArray-Struct (0 when not initialized)
If IsArray(Arr) Then DeRef ArrPtrSym(Arr), ArrPtrSaf Else DeRef Arr, ArrPtrSaf
End Function
Function ArrPtrDat(Arr) As Long 'returns a Ptr to the begin of the underlying data (0 when not initialized)
SafeArrayAccessData ArrPtrSaf(Arr), ArrPtrDat: SafeArrayUnaccessData ArrPtrSaf(Arr)
End Function
Function ArrDimens(Arr) As Long 'returns the Arr-Dimensions (0 when not initialized)
ArrDimens = SafeArrayGetDim(ArrPtrSaf(Arr))
End Function
Function ArrElemSz(Arr) As Long 'returns the size of an Array-Element in Bytes (0 when not initialized)
ArrElemSz = SafeArrayGetElemsize(ArrPtrSaf(Arr))
End Function
Function ArrLBound(Arr, Optional ByVal DimIdx As Long = 1) As Long
SafeArrayGetLBound ArrPtrSaf(Arr), DimIdx, ArrLBound
End Function
Function ArrUBound(Arr, Optional ByVal DimIdx As Long = 1) As Long
If ArrPtrSaf(Arr) Then SafeArrayGetUBound ArrPtrSaf(Arr), DimIdx, ArrUBound Else ArrUBound = -1
End Function
Function ArrLength(Arr, Optional ByVal DimIdx As Long = 1) As Long 'returns the amount of Array-Slots (for a given dimension)
ArrLength = ArrUBound(Arr, DimIdx) - ArrLBound(Arr, DimIdx) + 1
End Function
'returns the memory-size in Bytes, the Data-Allocation of the array currently occupies
'(optionally adds the mem-size of the SafeArray-Struct itself)
Function ArrMemory(Arr, Optional ByVal IncludeStructSize As Boolean) As Long
Dim i As Long
For i = 1 To ArrDimens(Arr): ArrMemory = IIf(ArrMemory, ArrMemory, 1) * ArrLength(Arr, i): Next
ArrMemory = ArrMemory * ArrElemSz(Arr)
If IncludeStructSize Then If ArrPtrSaf(Arr) Then ArrMemory = ArrMemory + ArrDimens(Arr) * 8 + 16
End FunctionOlaf