Изменение размерностей массива 1D, 2D в любых пределах

Option Explicit
#If Win64 Then
    Private Const ptrSz As LongPtr = 8
#Else
    Private Const ptrSz As Long = 4
#End If
Private Type SAFEARRAYBOUND
    cCount              As Long
    lBound              As Long
End Type
Private Type SAFEARRAY
    cDims               As Integer
    fFeatures           As Integer
    cbElements          As Long
    cLocks              As Long
    #If Win64 Then
      unused            As Long
    #End If
    pvData              As LongPtr
End Type
Private Type SAFEARRAY2D
    Hdr                 As SAFEARRAY
    Bounds(1)           As SAFEARRAYBOUND
End Type
Private Declare PtrSafe Sub CopyPtr Lib "kernel32.dll" Alias "RtlMoveMemory" (Dst As Any, Src As Any, Optional ByVal Size As LongPtr = ptrSz)
Private Declare PtrSafe Sub SafeArrayAllocDescriptor Lib "oleaut32.dll" (ByVal cDims As Long, ppsaOut As LongPtr)
Private Declare PtrSafe Sub SafeArrayDestroyDescriptor Lib "oleaut32.dll" (ByVal pSA As LongPtr)
Private Declare PtrSafe Function GetProcessHeap Lib "kernel32.dll" () As LongPtr
Private Declare PtrSafe Function HeapReAlloc Lib "kernel32.dll" (ByVal hHeap As LongPtr, ByVal dwFlags As Long, ByVal lpMem As LongPtr, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function HeapSize Lib "kernel32.dll" (ByVal hHeap As LongPtr, ByVal dwFlags As Long, ByVal lpMem As LongPtr) As LongPtr
Private Const HEAP_ZERO_MEMORY = &H8
 
Private Sub TestChangeArrayDims()
    Dim Arr$()
    ReDim Arr(0 To 19)
    Arr(2) = 222
    Stop
    ChangeArrayDims Arr, 1, 20
    Stop
    ChangeArrayDims Arr, 1, 20, 1, 1
    Stop
    ChangeArrayDims Arr, 1, 1, 1, 20
    Stop
    ChangeArrayDims Arr, 0, 19, 0, 0
    Stop
    ChangeArrayDims Arr, 1, 20, 1, 2
    Stop
End Sub
 
Private Sub ChangeStrArrayDims(sArr() As String, ByVal Lb1 As Long, ByVal Ub1 As Long, _
            Optional ByVal Lb2 As Long = -1, Optional ByVal Ub2 As Long = -1, Optional ByVal Rllc As Boolean)
    Dim SA As SAFEARRAY2D, pArr As LongPtr
    
    CopyPtr pArr, ByVal VarPtr(Lb1) - ptrSz           'получаем указатель массива
    
    ChangeArrayDims_ pArr, Lb1, Ub1, Lb2, Ub2, SA, Rllc
End Sub
Private Sub ChangeArrayDims(vArr, ByVal Lb1 As Long, ByVal Ub1 As Long, _
            Optional ByVal Lb2 As Long = -1, Optional ByVal Ub2 As Long = -1, Optional ByVal Rllc As Boolean)
    Dim SA As SAFEARRAY2D, pArr As LongPtr, vt%
    CopyPtr vt, vArr, 2
    If vt < &H4000 Then 'isVariant = True             'получаем указатель массива
        pArr = VarPtr(vArr) + 8
    Else
        CopyPtr pArr, ByVal VarPtr(vArr) + 8
    End If
    ChangeArrayDims_ pArr, Lb1, Ub1, Lb2, Ub2, SA, Rllc
End Sub
Private Sub ChangeArrayDims_(ByVal pArr As LongPtr, ByVal Lb1 As Long, ByVal Ub1 As Long, _
                              ByVal Lb2 As Long, ByVal Ub2 As Long, SA As SAFEARRAY2D, ByVal Rllc As Boolean)
    Dim ptSA As LongPtr, ptSA2 As LongPtr, tmpSA As SAFEARRAY, hHeap As LongPtr
    Dim newSize As LongPtr, curSize As LongPtr, Cnt1D&, Cnt2D&
    
    CopyPtr ptSA, ByVal pArr                          'получение указателя дескриптора массива Safearray
    CopyPtr ByVal VarPtr(Ub2) + ptrSz, ptSA           'устанавливаем указатель SA на дескриптор массива
    If SA.Hdr.cDims > 2 Then Exit Sub                 'поддерживаются только 1D и 2D массивы
    
    hHeap = GetProcessHeap
    curSize = HeapSize(hHeap, 0, SA.Hdr.pvData)       'текущий размер блока данных
    Cnt1D = Ub1 - Lb1 + 1
    If Lb2 < 0 Then                                   'если не заданы параметры 2й размерности
        newSize = Cnt1D * SA.Hdr.cbElements           'вычисляем требуемый размер блока данных
        GoSub ReAlloc                                 '~ Redim Preserve
        SA.Hdr.cDims = 1
        SA.Bounds(0).lBound = Lb1
        SA.Bounds(0).cCount = Cnt1D
    Else                                              'если заданы параметры 2й размерности
        If SA.Hdr.cDims <> 2 Then                     'если массив не 2D (а 1D) переделываем его н 2D
            LSet tmpSA = SA                           'сохраняем параметры дескриптора 1D массива
            SafeArrayAllocDescriptor 2, ptSA2         'создаем новый дескриптор массива размерности 2D
            CopyPtr ByVal VarPtr(Ub2) + ptrSz, ptSA2  'устанавливаем указатель SA на новый дескриптор массива
            LSet SA = tmpSA                           'восстанавливаем сохраненные параметры массива
            CopyPtr ByVal pArr, ptSA2                 'назначаем массиву новый 2D дескриптор
            SafeArrayDestroyDescriptor ptSA           'уничтожаем старый 1D дескриптор
            SA.Hdr.cDims = 2
        End If
        Cnt2D = Ub2 - Lb2 + 1
        newSize = Cnt1D * Cnt2D * SA.Hdr.cbElements   'вычисляем требуемый размер блока данных
        GoSub ReAlloc
        SA.Bounds(0).lBound = Lb2                     'устанавлииваем заданные 1D и 2D размерности
        SA.Bounds(0).cCount = Cnt2D
        SA.Bounds(1).lBound = Lb1
        SA.Bounds(1).cCount = Cnt1D
    End If
Exit Sub
ReAlloc:                                              'перераспределяем блок данных согласно требуемого размера
    Select Case True
    Case newSize > curSize, Rllc                      'HEAP_ZERO_MEMORY - заполнение нулями добавленного объема
        SA.Hdr.pvData = HeapReAlloc(hHeap, HEAP_ZERO_MEMORY, SA.Hdr.pvData, newSize)
    End Select
Return
End Sub