VB - Count dimensions of an array

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:

VB Code:

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

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.

Quote:

---

Originally Posted by 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.

---

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

VB Code:

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

;)

Quote:

---

Originally Posted by penagate

VB Code:

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

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.

Code:

---

' 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

---