VBA array slices (not in the Pythonic sense)
Note: the code has been updated, the original version can be found in the revision history (not that it is useful to find it). The updated code does not depend on the undocumented
GetMem*functions and is compatible with Office 64-bit.
I'm not sure I fully understand the logic and the connection between the function arguments and the result, but there already is a generic element accessor function, SafeArrayGetElement. It lets you access an element of an array with dimensions unknown at compile time, all you need is the array pointer.
In a separate module:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As LongPtr)
Private Declare PtrSafe Function SafeArrayGetElement Lib "oleaut32.dll" (ByVal psa As LongPtr, ByRef rgIndices As Long, ByRef pv As Any) As Long
Private Declare PtrSafe Function SafeArrayGetVartype Lib "oleaut32.dll" (ByVal psa As LongPtr, ByRef pvt As Integer) As Long
#Else
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
Private Declare Function SafeArrayGetElement Lib "oleaut32.dll" (ByVal psa As Long, ByRef rgIndices As Long, ByRef pv As Any) As Long
Private Declare Function SafeArrayGetVartype Lib "oleaut32.dll" (ByVal psa As Long, ByRef pvt As Integer) As Long
#End If
Private Const VT_BYREF As Long = &H4000&
Private Const S_OK As Long = &H0&
' When declared in this way, the passed array is wrapped in a Variant/ByRef. It is not copied.
' Returns *SAFEARRAY, not **SAFEARRAY
#If VBA7 Then
Private Function pArrPtr(ByRef arr As Variant) As LongPtr
#Else
Private Function pArrPtr(ByRef arr As Variant) As Long
#End If
'VarType lies to you, hiding important differences. Manual VarType here.
Dim vt As Integer
CopyMemory ByVal VarPtr(vt), ByVal VarPtr(arr), Len(vt)
If (vt And vbArray) <> vbArray Then
Err.Raise 5, , "Variant must contain an array"
End If
'see https://msdn.microsoft.com/en-us/library/windows/desktop/ms221627%28v=vs.85%29.aspx
If (vt And VT_BYREF) = VT_BYREF Then
'By-ref variant array. Contains **pparray at offset 8
CopyMemory ByVal VarPtr(pArrPtr), ByVal VarPtr(arr) + 8, Len(pArrPtr) 'pArrPtr = arr->pparray;
CopyMemory ByVal VarPtr(pArrPtr), ByVal pArrPtr, Len(pArrPtr) 'pArrPtr = *pArrPtr;
Else
'Non-by-ref variant array. Contains *parray at offset 8
CopyMemory ByVal VarPtr(pArrPtr), ByVal VarPtr(arr) + 8, Len(pArrPtr) 'pArrPtr = arr->parray;
End If
End Function
Public Function GetArrayElement(ByRef arr As Variant, ParamArray indices() As Variant) As Variant
#If VBA7 Then
Dim pSafeArray As LongPtr
#Else
Dim pSafeArray As Long
#End If
pSafeArray = pArrPtr(arr)
Dim long_indices() As Long
ReDim long_indices(0 To UBound(indices) - LBound(indices))
Dim i As Long
For i = LBound(long_indices) To UBound(long_indices)
long_indices(i) = indices(LBound(indices) + i)
Next
'Type safety checks - remove/cache if you know what you're doing.
Dim hresult As Long
Dim vt As Integer
hresult = SafeArrayGetVartype(pSafeArray, vt)
If hresult <> S_OK Then Err.Raise hresult, , "Cannot get array var type."
Select Case vt
Case vbVariant
hresult = SafeArrayGetElement(ByVal pSafeArray, long_indices(LBound(long_indices)), GetArrayElement)
Case vbBoolean, vbCurrency, vbDate, vbDecimal, vbByte, vbInteger, vbLong, vbNull, vbEmpty, vbSingle, vbDouble, vbString, vbObject
hresult = SafeArrayGetElement(ByVal pSafeArray, long_indices(LBound(long_indices)), ByVal VarPtr(GetArrayElement) + 8)
If hresult = S_OK Then CopyMemory ByVal VarPtr(GetArrayElement), ByVal VarPtr(vt), Len(vt)
Case Else
Err.Raise 5, , "Unsupported array element type"
End Select
If hresult <> S_OK Then Err.Raise hresult, , "Cannot get array element."
End Function
Usage:
Private Sub Command1_Click()
Dim arrVariantByRef() As Variant
ReDim arrVariantByRef(1 To 2, 1 To 3)
Dim arrVariantNonByRef As Variant
ReDim arrVariantNonByRef(1 To 2, 1 To 3)
Dim arrOfLongs() As Long
ReDim arrOfLongs(1 To 2, 1 To 3)
Dim arrOfStrings() As String
ReDim arrOfStrings(1 To 2, 1 To 3)
Dim arrOfObjects() As Object
ReDim arrOfObjects(1 To 2, 1 To 3)
Dim arrOfDates() As Date
ReDim arrOfDates(1 To 2, 1 To 3)
arrVariantByRef(2, 3) = 42
arrVariantNonByRef(2, 3) = 42
arrOfLongs(2, 3) = 42
arrOfStrings(2, 3) = "42!"
Set arrOfObjects(2, 3) = Me
arrOfDates(2, 3) = Now
MsgBox GetArrayElement(arrVariantByRef, 2, 3)
MsgBox GetArrayElement(arrVariantNonByRef, 2, 3)
MsgBox GetArrayElement(arrOfLongs, 2, 3)
MsgBox GetArrayElement(arrOfStrings, 2, 3)
MsgBox GetArrayElement(arrOfObjects, 2, 3).Caption
MsgBox GetArrayElement(arrOfDates, 2, 3)
End Sub
I believe you can easily build your logic using this base block, although it might be slower than you want.
There are some type checks in the code which you can remove - then it will be faster, but you will have to make sure you only pass arrays of correct underlying type. You can also cache the pArray and make GetArrayElement accept that instead of a raw array.
My complete code is below, arr input is 1, 2 or 3 dimension array, 1 dimension array will return false.
Public Function ArraySlice(arr As Variant, dimension As Long, index As Long) As Variant
Dim arrDimension() As Byte
Dim retArray()
Dim i As Integer, j As Integer
Dim arrSize As Long
' Get array dimension and size
On Error Resume Next
For i = 1 To 3
arrSize = 0
arrSize = CInt(UBound(arr, i))
If arrSize <> 0 Then
ReDim Preserve arrDimension(i)
arrDimension(i) = UBound(arr, i)
End If
Next i
On Error GoTo 0
Select Case UBound(arrDimension)
Case 2
If dimension = 1 Then
ReDim retArray(arrDimension(2))
For i = 0 To arrDimension(2)
retArray(i) = arr(index, i)
Next i
ElseIf dimension = 2 Then
ReDim retArray(arrDimension(1))
For i = 0 To arrDimension(1)
retArray(i) = arr(i, index)
Next i
End If
Case 3
If dimension = 1 Then
ReDim retArray(0, arrDimension(2), arrDimension(3))
For j = 0 To arrDimension(3)
For i = 0 To arrDimension(2)
retArray(0, i, j) = arr(index, i, j)
Next i
Next j
ElseIf dimension = 2 Then
ReDim retArray(arrDimension(1), 0, arrDimension(3))
For j = 0 To arrDimension(3)
For i = 0 To arrDimension(1)
retArray(i, 0, j) = arr(i, index, j)
Next i
Next j
ElseIf dimension = 3 Then
ReDim retArray(arrDimension(1), arrDimension(2), 0)
For j = 0 To arrDimension(2)
For i = 0 To arrDimension(1)
retArray(i, j, 0) = arr(i, j, index)
Next i
Next j
End If
Case Else
ArraySlice = False
Exit Function
End Select
ArraySlice = retArray
End Function
Simply test by the code below
Sub test()
Dim arr2D()
Dim arr3D()
Dim ret
ReDim arr2D(4, 3)
arr2D(0, 0) = 1
arr2D(1, 0) = 1
arr2D(2, 0) = 2
arr2D(3, 0) = 3
arr2D(4, 0) = 1
arr2D(0, 1) = 3
arr2D(1, 1) = 4
arr2D(2, 1) = 2
arr2D(3, 1) = 1
arr2D(4, 1) = 5
arr2D(0, 2) = 4
arr2D(1, 2) = 5
arr2D(2, 2) = 3
arr2D(3, 2) = 2
arr2D(4, 2) = 6
arr2D(0, 3) = 3
arr2D(1, 3) = 5
arr2D(2, 3) = 2
arr2D(3, 3) = 1
arr2D(4, 3) = 3
ReDim arr3D(2, 2, 2)
arr3D(0, 0, 0) = 1
arr3D(1, 0, 0) = 1
arr3D(2, 0, 0) = 1
arr3D(0, 1, 0) = 2
arr3D(1, 1, 0) = 2
arr3D(2, 1, 0) = 2
arr3D(0, 2, 0) = 3
arr3D(1, 2, 0) = 3
arr3D(2, 2, 0) = 3
arr3D(0, 0, 1) = 4
arr3D(1, 0, 1) = 4
arr3D(2, 0, 1) = 4
arr3D(0, 1, 1) = 5
arr3D(1, 1, 1) = 5
arr3D(2, 1, 1) = 5
arr3D(0, 2, 1) = 6
arr3D(1, 2, 1) = 6
arr3D(2, 2, 1) = 6
arr3D(0, 0, 2) = 7
arr3D(1, 0, 2) = 7
arr3D(2, 0, 2) = 7
arr3D(0, 1, 2) = 8
arr3D(1, 1, 2) = 8
arr3D(2, 1, 2) = 8
arr3D(0, 2, 2) = 9
arr3D(1, 2, 2) = 9
arr3D(2, 2, 2) = 9
ReDim arr3D(2, 2, 2)
arr3D(0, 0, 0) = "000"
arr3D(1, 0, 0) = "100"
arr3D(2, 0, 0) = "200"
arr3D(0, 1, 0) = "010"
arr3D(1, 1, 0) = "110"
arr3D(2, 1, 0) = "210"
arr3D(0, 2, 0) = "020"
arr3D(1, 2, 0) = "120"
arr3D(2, 2, 0) = "220"
arr3D(0, 0, 1) = "001"
arr3D(1, 0, 1) = "101"
arr3D(2, 0, 1) = "201"
arr3D(0, 1, 1) = "011"
arr3D(1, 1, 1) = "111"
arr3D(2, 1, 1) = "211"
arr3D(0, 2, 1) = "021"
arr3D(1, 2, 1) = "121"
arr3D(2, 2, 1) = "221"
arr3D(0, 0, 2) = "001"
arr3D(1, 0, 2) = "102"
arr3D(2, 0, 2) = "202"
arr3D(0, 1, 2) = "012"
arr3D(1, 1, 2) = "112"
arr3D(2, 1, 2) = "212"
arr3D(0, 2, 2) = "022"
arr3D(1, 2, 2) = "122"
arr3D(2, 2, 2) = "222"
' Here is function call
ret = ArraySlice(arr3D, 3, 1)
End If