Skip to content

Instantly share code, notes, and snippets.

@sancarn

sancarn/.README.md

Created September 24, 2023 10:00
Show Gist options
  • Save sancarn/04de8e0db85b5d2fee2b9817ba3f4998 to your computer and use it in GitHub Desktop.
Save sancarn/04de8e0db85b5d2fee2b9817ba3f4998 to your computer and use it in GitHub Desktop.
Download ZIP
A minimal sample of optimised CopyMemory for VBA
Raw
.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.

Raw
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment