Dynamically Redim Array Using Variables

Category:

Lists, Collections and Arrays

Type:

Snippets

Difficulty:

Advanced

Author:

Arkadiy Olovyannikov

Version Compatibility: Visual Basic 6, Visual Basic 5

More information:

VB ReDim statement allow you to use variables to set array bounds. But it doesn't allow to use variables as dimension numbers. In some cases (especially when working with tables) this can be useful.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
Option Explicit Type SAFEARRAYBOUND cElements As Long ' # of elements in the array dimension lLbound As Long ' lower bounds of the array dimension End Type Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal cBytes As Long) Private Declare Function SafeArrayCreate Lib "oleaut32" (ByVal vt As Integer, ByVal nDims As Long, rgsabound As SAFEARRAYBOUND) As Long 'SAFEARRAY pointer

Code:

'============Bas module code==========

Public Function DynamicRedim(ByRef TheArray As Variant, arrLBound() As Long, arrUBound() As Long, Optional vt As VbVarType = vbEmpty) As Boolean
   Dim i As Integer, nDims As Long
   Dim saBound() As SAFEARRAYBOUND
   If (LBound(arrLBound) <> LBound(arrUBound)) Or (UBound(arrLBound) <> UBound(arrUBound)) Then
       MsgBox "Invalid bounds", vbExclamation, "Error"
       Exit Function
   End If
   nDims = CInt(UBound(arrLBound) - LBound(arrLBound) + 1)
   If nDims < 1 Or nDims > 60 Then
      MsgBox "Invalid dimension number: " & nDims & vbCrLf & "VB array support 1 to 60 dims", vbExclamation, "Error"
      Exit Function
   End If
   If vt = vbEmpty Then vt = VarType(TheArray) 'Try to assign TheArray VarType
   vt = vt And Not vbArray 'Remove VT_ARRAY VarType
   If vt <= vbNull Then vt = vbVariant 'choose vbVariant type by default
   Dim lpArray As Long
   ReDim saBound(1 To nDims)
   For i = 1 To nDims
       saBound(i).lLbound = arrLBound(i)
       saBound(i).cElements = Abs(arrUBound(i) - arrLBound(i)) + 1
   Next i
   lpArray = SafeArrayCreate(vt, nDims, saBound(1))
   If lpArray = 0 Then Exit Function
   vt = vt Or vbArray 'add VT_ARRAY type
   CopyMemory ByVal VarPtr(TheArray), vt, 2
   CopyMemory ByVal VarPtr(TheArray) + 8, lpArray, (nDims) * Len(saBound(1)) + 16
   DynamicRedim = True
End Function

'=============Using - Form code==========
Private Sub Command1_Click()
   Dim MyArr As Variant
   Dim LBnd() As Long
   Dim UBnd() As Long
   Dim nDims As Integer
'You may set VarType explicity with ReDim:
'   ReDim MyArr(nDims) As String
'or set it later in DynamicRedim function calling
   nDims = 3
   ReDim LBnd(1 To nDims)
   ReDim UBnd(1 To nDims)
   LBnd(1) = 2: LBnd(2) = 1: LBnd(3) = 1
   UBnd(1) = 5: UBnd(2) = 3: UBnd(3) = 4
   If DynamicRedim(MyArr, LBnd, UBnd , vbString) = False Then
      MsgBox "Dynamic Redim failed!", vbExclamation, "Error"
   End If
   For i = 1 To nDims
       Debug.Print "Dimension " & i, LBound(MyArr, i) & " To " & UBound(MyArr, i) & "   VarType = " & VarType(MyArr(LBound(MyArr, 1), LBound(MyArr, 2), LBound(MyArr, 3)))
   Next i
   MyArr(2, 1, 1) = "Hello "
   MyArr(4, 3, 4) = "World!"
   Debug.Print MyArr(2, 1, 1) & MyArr(4, 3, 4)
End Sub