I've been quite annoyed lately by the fact that theCopyMemory API (RtlMoveMemory on Windows andMemMove on Mac) is running much slower than it used to, on certain computers. For example on one of my machines (x64 Windows and x32 Office) theCopyMemory API is running about 600 times slower than a month ago. I did do a Windows Update lately and maybe that is why. In thisSO question is seems that Windows Defender is the cause of slowness. Regardless of why the API is much slower, it is unusable if the operations involving the API need to run many times (e.g. millions of times).

Even without the issue mentioned above,CopyMemory API is slower than other alternatives. Since I did not want to use references tomsvbvm60.dll which is not available on most of my machines, I decided to create something similar with theGetMemX andPutMemX methods available in the mentioned dll. So, I created a couple of properties (Get/Let) calledMemByte,MemInt,MemLong andMemLongPtr using the sameByRef technique that I've used in theWeakReference repository. In short, I am using 2 Variants that have theVT_BYREF flag set inside the 2 Bytes holding theVarType. These 2 Variants allow remote read/write of memory.

Code

The full module with more explanations and also demos are available on GitHub atVBA-MemoryTools.

LibMemory standard module:

Option ExplicitOption Private Module'Used for raising errorsPrivate Const MODULE_NAME As String = "LibMemory"#If Mac Then    #If VBA7 Then        Public Declare PtrSafe Function CopyMemory Lib "/usr/lib/libc.dylib" Alias "memmove" (Destination As Any, source As Any, ByVal Length As LongPtr) As LongPtr    #Else        Public Declare Function CopyMemory 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        Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, source As Any, ByVal Length As LongPtr)    #Else        Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, source As Any, ByVal Length As Long)    #End If#End If#If VBA7 Then    Public Declare PtrSafe Function VarPtrArray Lib "VBE7.dll" Alias "VarPtr" (ByRef ptr() As Any) As LongPtr#Else    Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef ptr() As Any) As Long#End If'The size in bytes of a memory address#If Win64 Then    Public Const PTR_SIZE As Long = 8#Else    Public Const PTR_SIZE As Long = 4#End If#If Win64 Then    #If Mac Then        Public Const vbLongLong As Long = 20 'Apparently missing for x64 on Mac    #End If    Public Const vbLongPtr As Long = vbLongLong#Else    Public Const vbLongPtr As Long = vbLong#End IfPrivate Type REMOTE_MEMORY    memValue As Variant    remoteVT As Variant    isInitialized As Boolean 'In case state is lostEnd 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 VariantsPublic Const VT_BYREF As Long = &H4000Private m_remoteMemory As REMOTE_MEMORY'*******************************************************************************'Read/Write a Byte from/to memory'*******************************************************************************#If VBA7 ThenPublic Property Get MemByte(ByVal memAddress As LongPtr) As Byte#ElsePublic Property Get MemByte(ByVal memAddress As Long) As Byte#End If    DeRefMem m_remoteMemory, memAddress, vbByte    MemByte = m_remoteMemory.memValueEnd Property#If VBA7 ThenPublic Property Let MemByte(ByVal memAddress As LongPtr, ByVal newValue As Byte)#ElsePublic Property Let MemByte(ByVal memAddress As Long, ByVal newValue As Byte)#End If    DeRefMem m_remoteMemory, memAddress, vbByte    LetByRef(m_remoteMemory.memValue) = newValueEnd Property'*******************************************************************************'Read/Write 2 Bytes (Integer) from/to memory'*******************************************************************************#If VBA7 ThenPublic Property Get MemInt(ByVal memAddress As LongPtr) As Integer#ElsePublic Property Get MemInt(ByVal memAddress As Long) As Integer#End If    DeRefMem m_remoteMemory, memAddress, vbInteger    MemInt = m_remoteMemory.memValueEnd Property#If VBA7 ThenPublic Property Let MemInt(ByVal memAddress As LongPtr, ByVal newValue As Integer)#ElsePublic Property Let MemInt(ByVal memAddress As Long, ByVal newValue As Integer)#End If    DeRefMem m_remoteMemory, memAddress, vbInteger    LetByRef(m_remoteMemory.memValue) = newValueEnd Property'*******************************************************************************'Read/Write 4 Bytes (Long) from/to memory'*******************************************************************************#If VBA7 ThenPublic Property Get MemLong(ByVal memAddress As LongPtr) As Long#ElsePublic Property Get MemLong(ByVal memAddress As Long) As Long#End If    DeRefMem m_remoteMemory, memAddress, vbLong    MemLong = m_remoteMemory.memValueEnd Property#If VBA7 ThenPublic Property Let MemLong(ByVal memAddress As LongPtr, ByVal newValue As Long)#ElsePublic Property Let MemLong(ByVal memAddress As Long, ByVal newValue As Long)#End If    DeRefMem m_remoteMemory, memAddress, vbLong    LetByRef(m_remoteMemory.memValue) = newValueEnd Property'*******************************************************************************'Read/Write 8 Bytes (LongLong) from/to memory'*******************************************************************************#If VBA7 ThenPublic Property Get MemLongPtr(ByVal memAddress As LongPtr) As LongPtr#ElsePublic Property Get MemLongPtr(ByVal memAddress As Long) As Long#End If    DeRefMem m_remoteMemory, memAddress, vbLongPtr    MemLongPtr = m_remoteMemory.memValueEnd Property#If VBA7 ThenPublic Property Let MemLongPtr(ByVal memAddress As LongPtr, ByVal newValue As LongPtr)#ElsePublic Property Let MemLongPtr(ByVal memAddress As Long, ByVal newValue As Long)#End If    #If Win64 Then        'Cannot set Variant/LongLong ByRef so we use a Currency instead        Const currDivider As Currency = 10000        DeRefMem m_remoteMemory, memAddress, vbCurrency        LetByRef(m_remoteMemory.memValue) = CCur(newValue / currDivider)    #Else        MemLong(memAddress) = newValue    #End IfEnd Property'*******************************************************************************'Redirects the rm.memValue Variant to the new memory address so that the value'   can be read ByRef'*******************************************************************************Private Sub DeRefMem(ByRef rm As REMOTE_MEMORY, ByRef memAddress As LongPtr, ByRef vt As VbVarType)    With rm        If Not .isInitialized Then            'Link .remoteVt to the first 2 bytes of the .memValue Variant            .remoteVT = VarPtr(.memValue)            CopyMemory .remoteVT, vbInteger + VT_BYREF, 2            '            .isInitialized = True        End If        'Link .memValue to the desired address        .memValue = memAddress        LetByRef(.remoteVT) = vt + VT_BYREF 'Faster than: CopyMemory .memValue, vt + VT_BYREF, 2    End WithEnd Sub'*******************************************************************************'Utility for updating remote values that have the VT_BYREF flag set'*******************************************************************************Private Property Let LetByRef(ByRef v As Variant, ByRef newValue As Variant)    v = newValueEnd Property#If VBA7 ThenPublic Function UnsignedAddition(ByVal val1 As LongPtr, ByVal val2 As LongPtr) As LongPtr#ElsePublic Function UnsignedAddition(ByVal val1 As Long, ByVal val2 As Long) As Long#End If    'The minimum negative integer value of a Long Integer in VBA    #If Win64 Then    Const minNegative As LongLong = &H8000000000000000^ '-9,223,372,036,854,775,808 (dec)    #Else    Const minNegative As Long = &H80000000 '-2,147,483,648 (dec)    #End If    '    If val1 > 0 Then        If val2 > 0 Then            'Overflow could occur            If (val1 + minNegative + val2) < 0 Then                'The sum will not overflow                UnsignedAddition = val1 + val2            Else                'Example for Long data type (x32):                '   &H7FFFFFFD + &H0000000C =  &H80000009                '   2147483645 +         12 = -2147483639                UnsignedAddition = val1 + minNegative + val2 + minNegative            End If        Else 'Val2 <= 0            'Sum cannot overflow            UnsignedAddition = val1 + val2        End If    Else 'Val1 <= 0        If val2 > 0 Then            'Sum cannot overflow            UnsignedAddition = val1 + val2        Else 'Val2 <= 0            'Overflow could occur            On Error GoTo ErrorHandler            UnsignedAddition = val1 + val2        End If    End IfExit FunctionErrorHandler:    Err.Raise 6, MODULE_NAME & ".UnsignedAddition", "Overflow"End Function

Demo

For demos that are testing speed go to theDemo module in the above mentioned repository.

Sub DemoMem()    #If VBA7 Then        Dim ptr As LongPtr    #Else        Dim ptr As Long    #End If    Dim i As Long    Dim arr() As Variant    ptr = ObjPtr(Application)    '    'Read Memory using MemByte    ReDim arr(0 To PTR_SIZE - 1)    For i = LBound(arr) To UBound(arr)        arr(i) = MemByte(UnsignedAddition(ptr, i))    Next i    Debug.Print Join(arr, " ")    '    'Read Memory using MemInt    ReDim arr(0 To PTR_SIZE / 2 - 1)    For i = LBound(arr) To UBound(arr)        arr(i) = MemInt(UnsignedAddition(ptr, i * 2))    Next i    Debug.Print Join(arr, " ")    '    'Read Memory using MemLong    ReDim arr(0 To PTR_SIZE / 4 - 1)    For i = LBound(arr) To UBound(arr)        arr(i) = MemLong(UnsignedAddition(ptr, i * 4))    Next i    Debug.Print Join(arr, " ")    '    'Read Memory using MemLongPtr    Debug.Print MemLongPtr(ptr)    '    'Write Memory using MemByte    ptr = 0    MemByte(VarPtr(ptr)) = 24    Debug.Assert ptr = 24    MemByte(UnsignedAddition(VarPtr(ptr), 2)) = 24    Debug.Assert ptr = 1572888    '    'Write Memory using MemInt    ptr = 0    MemInt(UnsignedAddition(VarPtr(ptr), 2)) = 300    Debug.Assert ptr = 19660800    '    'Write Memory using MemLong    ptr = 0    MemLong(VarPtr(ptr)) = 77777    Debug.Assert ptr = 77777    '    'Write Memory using MemLongPtr    MemLongPtr(VarPtr(ptr)) = ObjPtr(Application)    Debug.Assert ptr = ObjPtr(Application)End Sub

Decisions

For those that are not aware, a LongLong integer cannot be modified ByRef if it is passed inside a Variant. Example:

#If Win64 ThenPrivate Sub DemoByRefLongLong()    Dim ll As LongLong    EditByRefLLVar ll, 1^End SubPrivate Sub EditByRefLLVar(ByRef ll As Variant, ByRef newValue As LongLong)    ll = newValue 'Error 458 - Variable uses an Automation type not supported...End Sub#End If

Since I couldn't use the same approach I've used for Byte, Integer and Long I've finally decided to go for the Currency approach because it was the cleanest and fastest. A Currency variable is stored using 8 Bytes in an integer format, scaled by 10,000 resulting in a fixed point number. So, it was quite easy to use currency instead ofLongLong (see theMemLongPtr Let property).

Another approach is to use a Double but looks absolutely horrendous (and is slower) and needs a secondREMOTE_MEMORY variable:

#If VBA7 ThenPublic Property Let MemLongPtr(ByVal memAddress As LongPtr, ByVal newValue As LongPtr)#ElsePublic Property Let MemLongPtr(ByVal memAddress As Long, ByVal newValue As Long)#End If    #If Win64 Then        Static rm As REMOTE_MEMORY        With rm            If Not .isInitialized Then                'Link .remoteVt to the first 2 bytes of the .memValue Variant                .remoteVT = VarPtr(.memValue)                CopyMemory .remoteVT, vbInteger + VT_BYREF, 2                '                .isInitialized = True            End If            .memValue = newValue            LetByRef(.remoteVT) = vbDouble        End With        DeRefMem m_remoteMemory, memAddress, vbDouble        LetByRef(m_remoteMemory.memValue) = rm.memValue    #Else        MemLong(memAddress) = newValue    #End IfEnd Property

Another approach is to write two Longs:

#If VBA7 ThenPublic Property Let MemLongPtr(ByVal memAddress As LongPtr, ByVal newValue As LongPtr)#ElsePublic Property Let MemLongPtr(ByVal memAddress As Long, ByVal newValue As Long)#End If    #If Win64 Then        MemLong(memAddress) = LoLong(newValue)        MemLong(UnsignedAddition(memAddress, 4)) = HiLong(newValue)    #Else        MemLong(memAddress) = newValue    #End IfEnd Property#If Win64 ThenPrivate Function HiLong(ByVal ll As LongLong) As Long    HiLong = VBA.Int(ll / &H100000000^)End FunctionPrivate Function LoLong(ByVal ll As LongLong) As Long    If ll And &H80000000^ Then        LoLong = CLng(ll And &H7FFFFFFF^) Or &H80000000    Else        LoLong = CLng(ll And &H7FFFFFFF^)    End IfEnd Function#End If

This approach looks dangerous because it might change half of a pointer first and by the time the second half is changed, some other code uses that pointer to do something that will likely result in a crash or data corruption.

Another decision was to leave theDeRefMem method as a Sub. Consider the current code (excluding the VBA7 declarations):

Public Property Get MemByte(ByVal memAddress As LongPtr) As Byte    DeRefMem m_remoteMemory, memAddress, vbByte    MemByte = m_remoteMemory.memValueEnd PropertyPublic Property Let MemByte(ByVal memAddress As LongPtr, ByVal newValue As Byte)    DeRefMem m_remoteMemory, memAddress, vbByte    LetByRef(m_remoteMemory.memValue) = newValueEnd PropertyPrivate Sub DeRefMem(ByRef rm As REMOTE_MEMORY, ByRef memAddress As LongPtr, ByRef vt As VbVarType)    With rm        If Not .isInitialized Then            .isInitialized = True            'Link .remoteVt to the first 2 bytes of the .memValue Variant            .remoteVT = VarPtr(.memValue)            CopyMemory .remoteVT, vbInteger + VT_BYREF, 2        End If        .memValue = memAddress        LetByRef(.remoteVT) = vt + VT_BYREF    End WithEnd Sub

and now the Function equivalent:

Public Property Get MemByte(ByVal memAddress As LongPtr) As Byte    MemByte = DeRefMem(memAddress, vbByte).memValueEnd PropertyPublic Property Let MemByte(ByVal memAddress As LongPtr, ByVal newValue As Byte)    LetByRef(DeRefMem(memAddress, vbByte).memValue) = newValueEnd PropertyPrivate Function DeRefMem(ByRef memAddress As LongPtr, ByRef vt As VbVarType) As REMOTE_MEMORY    Static rm As REMOTE_MEMORY    With rm        If Not .isInitialized Then            .isInitialized = True            'Link .remoteVt to the first 2 bytes of the .memValue Variant            .remoteVT = VarPtr(.memValue)            CopyMemory .remoteVT, vbInteger + VT_BYREF, 2        End If        .memValue = memAddress        LetByRef(.remoteVT) = vt + VT_BYREF    End With    DeRefMem = rmEnd Function

TheFunction approach looks definitely more readable. The problem is that it is 2-3 times slower than theSub equivalent. Since this code will act as a library, I went with the faster approach.

I would be very grateful for suggestions that could improve the code.
Have I missed anything obvious? Are there any other useful methods that should be part of such a 'Memory' library (e.g. like I've addedVarPtrArray andUnsignedAddition)?

I should also mention that although I wrote the necessary conditional compilations to make the code work for VB6, I cannot test it on VB6 because I don't have VB6 available.

Edit #1

The above has been extensively updated at the mentioned repository on GitHub atVBA-MemoryTools.

• \$\begingroup\$Why is the Function slower than the Sub?\$\endgroup\$

  Greedo

  – Greedo

  2020-12-01 12:26:50 +00:00

  CommentedDec 1, 2020 at 12:26
• 1
  \$\begingroup\$@Greedo Mainly because of the return value. If the return is just a Variant it seems to be 1.5x slower but that doesn't work for ByRef Variants so the return must be the whole UDT which is at least 2x slower. I've tested with multiples of 10 starting from 1000 to 10 milions (iterations) and it seems to be consistently slower. Quite unfortunate as it was definitely more elegant to have a Function instead. I assume the extra stack space and copy result operation are the reason\$\endgroup\$

  Cristian Buse

  – Cristian Buse

  2020-12-01 14:28:07 +00:00

  CommentedDec 1, 2020 at 14:28

1 Answer1

Start asking to get answers

Find the answer to your question by asking.

Explore related questions

See similar questions with these tags.