Partial Arrays by reference

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.

Yes, you can. You will have to construct a SAFEARRAY descriptor manually though, so that it points to a subset of the original array’s data.

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 SafeArrayAllocDescriptor Lib "oleaut32" (ByVal cDims As Long, ByVal ppsaOut As LongPtr) As Long
  Private Declare PtrSafe Function SafeArrayDestroyDescriptor Lib "oleaut32" (ByVal psa As LongPtr) 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 SafeArrayAllocDescriptor Lib "oleaut32" (ByVal cDims As Long, ppsaOut As Any) As Long
  Private Declare Function SafeArrayDestroyDescriptor Lib "oleaut32" (psa As Any) 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 ppArrPtr(ByRef arr As Variant) As LongPtr
#Else
Private Function ppArrPtr(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(ppArrPtr), ByVal VarPtr(arr) + 8, Len(ppArrPtr)  'pArrPtr = arr->pparray;
  Else
    'Non-by-ref variant array. Contains *parray at offset 8
    Err.Raise 5, , "The array must be passed by reference."
  End If
End Function

#If VBA7 Then
Public Function CreateSAFEARRAY(ByRef BlankArray As Variant, ByVal ElemSize As Long, ByVal pData As LongPtr, ParamArray Bounds()) As LongPtr
#Else
Public Function CreateSAFEARRAY(ByRef BlankArray As Variant, ByVal ElemSize As Long, ByVal pData As Long, ParamArray Bounds()) As Long
#End If

 'ParamArray Bounds describes desired array dimensions in VB style
 'bounds(0) - lower bound of first dimension
 'bounds(1) - upper bound of first dimension
 'bounds(2) - lower bound of second dimension
 'bounds(3) - upper bound of second dimension
 'etc

  If (UBound(Bounds) - LBound(Bounds) + 1) Mod 2 Then Err.Raise 5, "SafeArray", "Bounds must contain even number of entries."

#If VBA7 Then
  Dim ppBlankArr As LongPtr
#Else
  Dim ppBlankArr As Long
#End If

  ppBlankArr = ppArrPtr(BlankArray)

  If SafeArrayAllocDescriptor((UBound(Bounds) - LBound(Bounds) + 1) / 2, ByVal ppBlankArr) <> S_OK Then Err.Raise 5

  CopyMemory ByVal VarPtr(CreateSAFEARRAY), ByVal ppBlankArr, Len(CreateSAFEARRAY)  ' CreateSAFEARRAY = *ppBlankArr
  CopyMemory ByVal CreateSAFEARRAY + 4, ByVal VarPtr(ElemSize), Len(ElemSize)       ' CreateSAFEARRAY->cbElements = ElemSize
  CopyMemory ByVal CreateSAFEARRAY + 12, ByVal VarPtr(pData), Len(pData)            ' CreateSAFEARRAY->pvData = pData

  Dim i As Long

  For i = LBound(Bounds) To UBound(Bounds) - 1 Step 2
    If Bounds(i + 1) - Bounds(i) + 1 > 0 Then
      Dim dimensions_data(1 To 2) As Long
      dimensions_data(1) = Bounds(i + 1) - Bounds(i) + 1
      dimensions_data(2) = Bounds(i)

      CopyMemory ByVal CreateSAFEARRAY + 16 + (UBound(Bounds) - i - 1) * 4, ByVal VarPtr(dimensions_data(LBound(dimensions_data))), Len(dimensions_data(LBound(dimensions_data))) * 2 ' CreateSAFEARRAY->rgsabound[i] = number of elements, lower bound
    Else
      SafeArrayDestroyDescriptor ByVal CreateSAFEARRAY
      CreateSAFEARRAY = 0
      CopyMemory ByVal ppBlankArr, ByVal VarPtr(CreateSAFEARRAY), Len(ppBlankArr) ' ppBlankArr = NULL (because CreateSAFEARRAY is now 0)
      Err.Raise 5, , "Each dimension must contain at least 1 element"
    End If
  Next
End Function

Public Sub DestroySAFEARRAY(ByRef ManualArray As Variant)
#If VBA7 Then
  Dim ppManualArr As LongPtr
  Dim pManualArr As LongPtr
#Else
  Dim ppManualArr As Long
  Dim pManualArr As Long
#End If

  ppManualArr = ppArrPtr(ManualArray)
  CopyMemory ByVal VarPtr(pManualArr), ByVal ppManualArr, Len(pManualArr)  ' pManualArr = *ppManualArr

  If SafeArrayDestroyDescriptor(ByVal pManualArr) <> S_OK Then Err.Raise 5

  pManualArr = 0 ' Simply to get a LongPtr-sized zero
  CopyMemory ByVal ppManualArr, ByVal VarPtr(pManualArr), Len(ppManualArr)  'ppManualArr = NULL
End Sub

Usage:

Dim source(0 To 5) As Long
source(0) = 0: source(1) = 1: source(2) = 2: source(3) = 3: source(4) = 4: source(5) = 5

Dim a() As Long
Dim b() As Long

CreateSAFEARRAY a, 4, VarPtr(source(0)), 0, 2
CreateSAFEARRAY b, 4, VarPtr(source(3)), 0, 2

MsgBox b(0)

a(0) = 4

DestroySAFEARRAY a
DestroySAFEARRAY b

MsgBox source(0)

Be sure to manually destroy the child arrays before the original array variable gets destroyed by either Erase or going out of scope.

However, it might be simpler to just pass the whole an array by reference to a subroutine and also provide the index number from which to start processing.

More Related Contents:

Leave a Comment Cancel reply