VB - Count dimensions of an array

[sciguyryan]

I was sick of the old code I used to use to do this - when using large dimensions it could get quite slow so, I decided to investigate if it was possible using API and as it turns out it is, here is what I came up with:

Private Declare Sub RtlMoveMemory Lib "kernel32.dll" ( _
    ByRef Destination As Any, _
    ByRef Source As Any, _
    ByVal Length As Long)
 
Private Const VT_BYREF = &H4000&
 
Private Function ArrayDims(varArray As Variant) As Integer
    Dim lngPointer As Long
    Dim intType As Integer
    
    RtlMoveMemory intType, varArray, 2
    If (intType And vbArray) = 0 Then
        Exit Function
    End If
    RtlMoveMemory lngPointer, ByVal VarPtr(varArray) + 8, 4
    If (intType And VT_BYREF) Then
        RtlMoveMemory lngPointer, ByVal lngPointer, 4
    End If
    If lngPointer Then
        RtlMoveMemory ArrayDims, ByVal lngPointer, 2
    End If
End Function

Hope that helps someone,

Cheers,

RyanJ

[penagate]

What's wrong with UBound and LBound?

Also, when working with CopyMemory (MoveMemory if you like) I pass the address of the 1st element of the array, instead of the entire thing. Saves using a variant, is a bit quicker.

Although, now I look at your code again, it's obvious that the whole thing is needed, so scrap that last comment.

[sciguyryan]

What's wrong with UBound and LBound?

Also, when working with CopyMemory (MoveMemory if you like) I pass the address of the 1st element of the array, instead of the entire thing. Saves using a variant, is a bit quicker.

Although, now I look at your code again, it's obvious that the whole thing is needed, so scrap that last comment.

Hmm, can you use UBound and LBound on multi-dimension arrays?


If yes then this is still an example to show how it is possible through pure code

Cheers,

RyanJ

[penagate]

Dim UglyArray(2 To 5, 3 To 9) As UglyType
LBound(UglyArray, 1) ' Returns 2
UBound(UglyArray, 1) ' Returns 5
LBound(UglyArray, 2) ' Returns 3
UBound(UglyArray, 2) ' Returns 9

[sciguyryan]

Dim UglyArray(2 To 5, 3 To 9) As UglyType
LBound(UglyArray, 1) ' Returns 2
UBound(UglyArray, 1) ' Returns 5
LBound(UglyArray, 2) ' Returns 3
UBound(UglyArray, 2) ' Returns 9

I never knew that - you do learn soemthing new every day with the experts around anyway

Thanks for the information

Cheers,

RyanJ

[penagate]

More array bounds fun
I can't claim credit for this code though, I got it off the vbAdvance website.
Basically instead of throwing an error when a dynamic array has not yet been initialised, it returns -1 instead.

Just chuck it all in a module.

' See this article:
' >> http://www.vbadvance.com/arrays.htm

Option Base 0
Option Compare Binary
Option Explicit

Private Const VT_BYREF = &H4000
Private Const VARIANT_DATA_OFFSET As Long = 8

Private Declare Function SafeArrayGetDim Lib "oleaut32.dll" _
    (ByVal pSA As Long) _
    As Long

Private Declare Function SafeArrayGetLBound Lib "oleaut32.dll" _
    (ByVal pSA As Long, _
     ByVal nDim As Long, _
     ByRef plLbound As Long) _
    As Long

Private Declare Function SafeArrayGetUBound Lib "oleaut32.dll" _
    (ByVal pSA As Long, _
     ByVal nDim As Long, _
     ByRef plUbound As Long) _
    As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (ByRef lpDest As Any, _
     ByRef lpSource As Any, _
     ByVal lByteLen As Long)
'


Public Function LBoundEx(ByRef vArray As Variant, _
                         Optional ByVal lDimension As Long = 1) As Long
    
    Dim iDataType As Integer
    Dim pSA As Long
    
    'Make sure an array was passed in:
    If IsArray(vArray) Then
        
        'Try to get the pointer:
        CopyMemory pSA, ByVal VarPtr(vArray) + VARIANT_DATA_OFFSET, 4
        
        If pSA Then
            
            'If byref then deref the pointer to get the actual pointer:
            CopyMemory iDataType, vArray, 2
            If iDataType And VT_BYREF Then
                CopyMemory pSA, ByVal pSA, 4
            End If
            
            If pSA Then
                If lDimension > 0 Then
                    'Make sure this is a valid array dimension:
                    If lDimension <= SafeArrayGetDim(pSA) Then
                        'Get the LBound:
                        SafeArrayGetLBound pSA, lDimension, LBoundEx
                    Else
                        LBoundEx = -1
                    End If
                Else
                    Err.Raise vbObjectError Or 10000, "LBoundEx", "Invalid Dimension"
                End If
            Else
                LBoundEx = -1
            End If
        Else
            LBoundEx = -1
        End If
    Else
        Err.Raise vbObjectError Or 10000, "LBoundEx", "Not an array"
    End If
    
End Function


Public Function UBoundEx(ByRef vArray As Variant, _
                         Optional ByVal lDimension As Long = 1) As Long
    
    Dim iDataType As Integer
    Dim pSA As Long
    
    'Make sure an array was passed in:
    If IsArray(vArray) Then
        
        'Try to get the pointer:
        CopyMemory pSA, ByVal VarPtr(vArray) + VARIANT_DATA_OFFSET, 4
        
        If pSA Then
            
            'If byref then deref the pointer to get the actual pointer:
            CopyMemory iDataType, vArray, 2
            If iDataType And VT_BYREF Then
                CopyMemory pSA, ByVal pSA, 4
            End If
            
            If pSA Then
                If lDimension > 0 Then
                    'Make sure this is a valid array dimension:
                    If lDimension <= SafeArrayGetDim(pSA) Then
                        'Get the UBound:
                        SafeArrayGetUBound pSA, lDimension, UBoundEx
                    Else
                        UBoundEx = -1
                    End If
                Else
                    Err.Raise vbObjectError Or 10000, "UBoundEx", "Invalid Dimension"
                End If
            Else
                UBoundEx = -1
            End If
        Else
            UBoundEx = -1
        End If
    Else
        Err.Raise vbObjectError Or 10000, "UBoundEx", "Not an array"
    End If
    
End Function