A minimal sample of optimised CopyMemory for VBA

.README.md

MCopyMemory

Based almost entirely on the work of cristianbuse's MemoryModule, this is merely a minimal example and substitute for CopyMemory in VBA without any other helper functions.

Kudos to Cristian for building the original solution.

MCopyMemory.bas

Attribute VB_Name = "MCopyMemory"

Option Explicit
Option Private Module

#If Mac Then
    #If VBA7 Then
        Private Declare PtrSafe Function CopyMemoryAPI Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As LongPtr) As LongPtr
    #Else
        Private Declare Function CopyMemoryAPI Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, Source As Any, ByVal Length As Long) As Long
    #End If
#Else 'Windows
    'https://msdn.microsoft.com/en-us/library/mt723419(v=vs.85).aspx
    #If VBA7 Then
        Private Declare PtrSafe Sub CopyMemoryAPI Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    #Else
        Private Declare Sub CopyMemoryAPI Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    #End If
#End If

#If VBA7 = 0 Then       'LongPtr trick discovered by @Greedo (https://github.com/Greedquest)
    Private Enum LongPtr
        [_]
    End Enum
#End If                 'https://github.com/cristianbuse/VBA-MemoryTools/issues/3

#If Win64 Then
    Private Const PTR_SIZE As Long = 8
    Private Const VARIANT_SIZE As Long = 24
#Else
    Private Const PTR_SIZE As Long = 4
    Private Const VARIANT_SIZE As Long = 16
#End If

Private Const BYTE_SIZE As Long = 1
Private Const INT_SIZE As Long = 2
Private Const VT_SPACING As Long = VARIANT_SIZE / INT_SIZE 'VarType spacing in an array of Variants

#If Win64 Then
    #If Mac Then
        Private Const vbLongLong As Long = 20 'Apparently missing for x64 on Mac
    #End If
    Private Const vbLongPtr As Long = vbLongLong
#Else
    Private Const vbLongLong As Long = 20 'Useful in Select Case logic
    Private Const vbLongPtr As Long = vbLong
#End If

Private Type REMOTE_MEMORY
    memValue As Variant
    remoteVT As Variant 'Will be linked to the first 2 bytes of 'memValue' - see 'InitRemoteMemory'
    isInitialized As Boolean 'In case state is lost
End Type

'https://docs.microsoft.com/en-us/openspecs/windows_protocols/ms-oaut/3fe7db9f-5803-4dc4-9d14-5425d3f5461f
'https://docs.microsoft.com/en-us/windows/win32/api/oaidl/ns-oaidl-variant?redirectedfrom=MSDN
'Flag used to simulate ByRef Variants
Private Const VT_BYREF As Long = &H4000

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type
Private Type SAFEARRAY_1D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    #If Win64 Then
        dummyPadding As Long
        pvData As LongLong
    #Else
        pvData As Long
    #End If
    rgsabound0 As SAFEARRAYBOUND
End Type
Private Const FADF_HAVEVARTYPE As Long = &H80


'*******************************************************************************
'Alternative for CopyMemory - not affected by API speed issues on Windows
'--------------------------
'Mac - wrapper around CopyMemory/memmove
'Win - bytesCount 1 to 2147483647 - no API calls. Uses a combination of
'      REMOTE_MEMORY/SAFEARRAY_1D structs as well as native Strings and Arrays
'      to manipulate memory. Works within size limitation of Strings in VBA
'      For some smaller sizes (<=5) optimizes via MemLong, MemInt, MemByte etc.
'    - bytesCount < 0 or > 2147483647 - wrapper around CopyMemory/RtlMoveMemory
'*******************************************************************************
Public Sub CopyMemory(ByVal destinationPtr As LongPtr _
                 , ByVal sourcePtr As LongPtr _
                 , ByVal bytesCount As LongPtr)
    If destinationPtr = sourcePtr Then Exit Sub
#If Mac Then
    CopyMemoryAPI ByVal destinationPtr, ByVal sourcePtr, bytesCount
#Else
    #If Win64 Then
        Const maxLong As Long = &H7FFFFFFF
        If bytesCount < 0 Or bytesCount > maxLong Then
    #Else
        If bytesCount < 0 Then
    #End If
        CopyMemoryAPI ByVal destinationPtr, ByVal sourcePtr, bytesCount
        Exit Sub
    End If
    
    If bytesCount <= 4 Then
      'Cannot use BSTR
      Dim i As Long
      For i = 1 To CLng(bytesCount)
        MemByte(destinationPtr + i - 1) = MemByte(sourcePtr + i - 1)
      Next
    Else
      'Structs used to read/write memory
      Static sArrByte As SAFEARRAY_1D
      Static rmArrSrc As REMOTE_MEMORY
      Static rmSrc As REMOTE_MEMORY
      Static rmDest As REMOTE_MEMORY
      Static rmBSTR As REMOTE_MEMORY
      '
      If Not rmArrSrc.isInitialized Then
          With sArrByte
              .cDims = 1
              .fFeatures = FADF_HAVEVARTYPE
              .cbElements = BYTE_SIZE
          End With
          rmArrSrc.memValue = VarPtr(sArrByte)
          '
          InitRemoteMemory rmArrSrc
          InitRemoteMemory rmSrc
          InitRemoteMemory rmDest
          InitRemoteMemory rmBSTR
      End If
      '
      rmSrc.memValue = sourcePtr
      rmDest.memValue = destinationPtr
      CopyBytes CLng(bytesCount), rmSrc, rmSrc.remoteVT, rmDest, rmDest.remoteVT _
          , rmDest.memValue, sArrByte, rmArrSrc.memValue, rmArrSrc.remoteVT _
          , rmBSTR, rmBSTR.remoteVT, rmBSTR.memValue
    End If
#End If
End Sub

'*******************************************************************************
'Read/Write a Byte from/to memory
'*******************************************************************************
Private Property Get MemByte(ByVal memAddress As LongPtr) As Byte
    #If Mac Then
        CopyMemoryAPI MemByte, ByVal memAddress, 1
    #Else
        Static rm As REMOTE_MEMORY
        RemoteAssign rm, memAddress, rm.remoteVT, vbByte + VT_BYREF, MemByte, rm.memValue
    #End If
End Property
Private Property Let MemByte(ByVal memAddress As LongPtr, ByVal newValue As Byte)
    #If Mac Then
        CopyMemoryAPI ByVal memAddress, newValue, 1
    #Else
        Static rm As REMOTE_MEMORY
        RemoteAssign rm, memAddress, rm.remoteVT, vbByte + VT_BYREF, rm.memValue, newValue
    #End If
End Property

'*******************************************************************************
'Utility for 'MemCopy' - avoids extra stack frames
'The 'bytesCount' expected to be larger than 4 because the first 4 bytes are
'   needed for the destination BSTR's length.
'The source can either be a String or an array of bytes depending on the first 4
'   bytes in the source. Choice between the 2 is based on speed considerations
'Note that no byte is changed in source regardless if BSTR or SAFEARRAY is used
'*******************************************************************************
Private Sub CopyBytes(ByVal bytesCount As Long _
                    , ByRef rmSrc As REMOTE_MEMORY, ByRef vtSrc As Variant _
                    , ByRef rmDest As REMOTE_MEMORY, ByRef vtDest As Variant _
                    , ByRef destValue As Variant, ByRef sArr As SAFEARRAY_1D _
                    , ByRef arrBytes As Variant, ByRef vtArr As Variant _
                    , ByRef rmBSTR As REMOTE_MEMORY, ByRef vtBSTR As Variant _
                    , ByRef bstrPtrValue As Variant)
    Const bstrPrefixSize As Long = 4
    Dim bytes As Long: bytes = bytesCount - bstrPrefixSize
    Dim bstrLength As Long
    Dim s As String 'Must not be Variant so that LSet is faster
    Dim tempSize As Long
    Dim useBSTR As Boolean
    Dim hasOverlap As Boolean
    Dim overlapBSTRLen As Long
    Dim overlapOffset As LongPtr
    '
    Do
        vtSrc = vbLong + VT_BYREF
        bstrLength = rmSrc.memValue 'Copy first 4 bytes froum source
        vtSrc = vbLongPtr
        '
        Const maxMidBs As Long = 2 ^ 5 'Use SAFEARRAY and MidB below this value
        useBSTR = (bstrLength >= bytes Or bstrLength < 0) And bytes > maxMidBs
        If useBSTR Then 'Prepare source BSTR
            rmBSTR.memValue = VarPtr(s)
            #If Win64 Then
                Const curBSTRPrefixSize As Currency = 0.0004
                vtSrc = vbCurrency
                vtBSTR = vbCurrency + VT_BYREF
                bstrPtrValue = rmSrc.memValue + curBSTRPrefixSize
                vtSrc = vbLongPtr
            #Else
                vtBSTR = vbLong + VT_BYREF
                bstrPtrValue = rmSrc.memValue + bstrPrefixSize
            #End If
            Const maxStartMidB As Long = 2 ^ 30 'MidB second param limit (bug)
            If bytes > maxStartMidB And bytes Mod 2 = 1 Then
                tempSize = maxStartMidB
                bytes = bytes - maxStartMidB
            Else
                tempSize = bytes
                bytes = 0
            End If
        Else 'Prepare source SAFEARRAY
            'For large amounts it is faster to copy memory in smaller chunks
            Const chunkSize As Long = 2 ^ 16 'Similar performance with 2 ^ 17
            '
            If bytes > chunkSize + bstrPrefixSize + 1 Then
                tempSize = chunkSize
                bytes = bytes - chunkSize - bstrPrefixSize
            Else
                tempSize = bytes
                bytes = 0
            End If
            sArr.pvData = rmSrc.memValue + bstrPrefixSize
            sArr.rgsabound0.cElements = tempSize
            vtArr = vbArray + vbByte
        End If
        '
        'Prepare destination BSTR
        If rmDest.memValue + 4 > rmSrc.memValue Then
            hasOverlap = UnsignedAdd(rmSrc.memValue, tempSize + bstrPrefixSize) > rmDest.memValue
            If hasOverlap Then overlapOffset = rmDest.memValue - rmSrc.memValue
        Else
            hasOverlap = False
        End If
        vtDest = vbLong + VT_BYREF
        If hasOverlap Then overlapBSTRLen = destValue
        destValue = tempSize
        vtDest = vbLongPtr
        rmDest.memValue = rmDest.memValue + bstrPrefixSize
        vtDest = vbString
        '
        'Copy and clean
        If useBSTR Then
            LSet destValue = s 'LSet cannot copy an odd number of bytes
            If tempSize Mod 2 = 1 Then
                MidB(destValue, tempSize, 1) = MidB$(s, tempSize, 1)
            End If
            bstrPtrValue = 0
            vtBSTR = vbEmpty
        Else
            Const maxMidBa As Long = maxMidBs * 2 ^ 3
            If tempSize > maxMidBa Then
                LSet destValue = arrBytes
                If tempSize Mod 2 = 1 Then
                    Static lastByte(0 To 0) As Byte
                    lastByte(0) = arrBytes(UBound(arrBytes))
                    MidB(destValue, tempSize, 1) = lastByte
                End If
            Else
                MidB(destValue, 1) = arrBytes
            End If
            vtArr = vbEmpty
        End If
        '
        vtDest = vbLongPtr
        rmDest.memValue = rmDest.memValue - bstrPrefixSize
        vtDest = vbLong + VT_BYREF
        destValue = bstrLength 'Copy the correct 'BSTR length' bytes
        vtDest = vbLongPtr
        If hasOverlap Then
            rmDest.memValue = rmDest.memValue + overlapOffset
            vtDest = vbLong + VT_BYREF
            destValue = overlapBSTRLen
            vtDest = vbLongPtr
            rmDest.memValue = rmDest.memValue - overlapOffset
        End If
        '
        If bytes > 0 Then 'Advance address for next chunk
            Dim bytesOffset As Long: bytesOffset = chunkSize + bstrPrefixSize
            rmDest.memValue = UnsignedAdd(rmDest.memValue, bytesOffset)
            rmSrc.memValue = UnsignedAdd(rmSrc.memValue, bytesOffset)
        End If
    Loop Until bytes = 0
End Sub

'Method purpose explanation at:
'https://gist.github.com/cristianbuse/b9cc79164c1d31fdb30465f503ac36a9
'
'Practical note Jan-2021 from Vladimir Vissoultchev (https://github.com/wqweto):
'This is mostly not needed in client application code even for LARGEADDRESSAWARE
'   32-bit processes nowadays as a reliable technique to prevent pointer
'   arithmetic overflows is to VirtualAlloc a 64KB sentinel chunk around 2GB
'   boundary at application start up so that the boundary is never (rarely)
'   crossed in normal pointer operations.
'This same sentinel chunk fixes native PropertyBag as well which has troubles
'   when internal storage crosses 2GB boundary.
Private Function UnsignedAdd(ByVal unsignedPtr As LongPtr, ByVal signedOffset As LongPtr) As LongPtr
    #If Win64 Then
        Const minNegative As LongLong = &H8000000000000000^
    #Else
        Const minNegative As Long = &H80000000
    #End If
    UnsignedAdd = ((unsignedPtr Xor minNegative) + signedOffset) Xor minNegative
End Function


'*******************************************************************************
'Returns an initialized (linked) REMOTE_MEMORY struct
'Links .remoteVt to the first 2 bytes of .memValue
'*******************************************************************************
Private Sub InitRemoteMemory(ByRef rm As REMOTE_MEMORY)
    rm.remoteVT = VarPtr(rm.memValue)
    MemIntAPI(VarPtr(rm.remoteVT)) = vbInteger + VT_BYREF
    rm.isInitialized = True
End Sub

'*******************************************************************************
'The only method in this module that uses CopyMemory!
'Assures that InitRemoteMemory can link the Var Type for new structs
'*******************************************************************************
Private Property Let MemIntAPI(ByVal memAddress As LongPtr, ByVal newValue As Integer)
    Static rm As REMOTE_MEMORY
    If Not rm.isInitialized Then 'Link .remoteVt to .memValue's first 2 bytes
        rm.remoteVT = VarPtr(rm.memValue)
        CopyMemoryAPI rm.remoteVT, vbInteger + VT_BYREF, 2
        rm.isInitialized = True
    End If
    RemoteAssign rm, memAddress, rm.remoteVT, vbInteger + VT_BYREF, rm.memValue, newValue
End Property

'*******************************************************************************
'This method assures the required redirection for both the remote varType and
'   the remote value at the same time thus removing any additional stack frames
'It can be used to both read from and write to memory by swapping the order of
'   the last 2 parameters
'*******************************************************************************
Private Sub RemoteAssign(ByRef rm As REMOTE_MEMORY _
                       , ByRef memAddress As LongPtr _
                       , ByRef remoteVT As Variant _
                       , ByVal newVT As VbVarType _
                       , ByRef targetVariable As Variant _
                       , ByRef newValue As Variant)
    rm.memValue = memAddress
    If Not rm.isInitialized Then InitRemoteMemory rm
    remoteVT = newVT
    targetVariable = newValue
    remoteVT = vbEmpty 'Stop linking to remote address, for safety
End Sub