6
\$\begingroup\$

I've been quite annoyed lately by the fact that the CopyMemory API (RtlMoveMemory on Windows and MemMove 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) the CopyMemory API is running about 600 times slower than a month ago. I did do a Windows Update lately and maybe that is why. In this SO 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 to msvbvm60.dll which is not available on most of my machines, I decided to create something similar with the GetMemX and PutMemX methods available in the mentioned dll. So, I created a couple of properties (Get/Let) called MemByte, MemInt, MemLong and MemLongPtr using the same ByRef technique that I've used in the WeakReference repository. In short, I am using 2 Variants that have the VT_BYREF flag set inside the 2 Bytes holding the VarType. These 2 Variants allow remote read/write of memory.

Code

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

LibMemory standard module:

Option Explicit
Option Private Module

'Used for raising errors
Private 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 If

Private Type REMOTE_MEMORY
    memValue As Variant
    remoteVT As Variant
    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
Public Const VT_BYREF As Long = &H4000

Private m_remoteMemory As REMOTE_MEMORY

'*******************************************************************************
'Read/Write a Byte from/to memory
'*******************************************************************************
#If VBA7 Then
Public Property Get MemByte(ByVal memAddress As LongPtr) As Byte
#Else
Public Property Get MemByte(ByVal memAddress As Long) As Byte
#End If
    DeRefMem m_remoteMemory, memAddress, vbByte
    MemByte = m_remoteMemory.memValue
End Property
#If VBA7 Then
Public Property Let MemByte(ByVal memAddress As LongPtr, ByVal newValue As Byte)
#Else
Public Property Let MemByte(ByVal memAddress As Long, ByVal newValue As Byte)
#End If
    DeRefMem m_remoteMemory, memAddress, vbByte
    LetByRef(m_remoteMemory.memValue) = newValue
End Property

'*******************************************************************************
'Read/Write 2 Bytes (Integer) from/to memory
'*******************************************************************************
#If VBA7 Then
Public Property Get MemInt(ByVal memAddress As LongPtr) As Integer
#Else
Public Property Get MemInt(ByVal memAddress As Long) As Integer
#End If
    DeRefMem m_remoteMemory, memAddress, vbInteger
    MemInt = m_remoteMemory.memValue
End Property

#If VBA7 Then
Public Property Let MemInt(ByVal memAddress As LongPtr, ByVal newValue As Integer)
#Else
Public Property Let MemInt(ByVal memAddress As Long, ByVal newValue As Integer)
#End If
    DeRefMem m_remoteMemory, memAddress, vbInteger
    LetByRef(m_remoteMemory.memValue) = newValue
End Property

'*******************************************************************************
'Read/Write 4 Bytes (Long) from/to memory
'*******************************************************************************
#If VBA7 Then
Public Property Get MemLong(ByVal memAddress As LongPtr) As Long
#Else
Public Property Get MemLong(ByVal memAddress As Long) As Long
#End If
    DeRefMem m_remoteMemory, memAddress, vbLong
    MemLong = m_remoteMemory.memValue
End Property
#If VBA7 Then
Public Property Let MemLong(ByVal memAddress As LongPtr, ByVal newValue As Long)
#Else
Public Property Let MemLong(ByVal memAddress As Long, ByVal newValue As Long)
#End If
    DeRefMem m_remoteMemory, memAddress, vbLong
    LetByRef(m_remoteMemory.memValue) = newValue
End Property

'*******************************************************************************
'Read/Write 8 Bytes (LongLong) from/to memory
'*******************************************************************************
#If VBA7 Then
Public Property Get MemLongPtr(ByVal memAddress As LongPtr) As LongPtr
#Else
Public Property Get MemLongPtr(ByVal memAddress As Long) As Long
#End If
    DeRefMem m_remoteMemory, memAddress, vbLongPtr
    MemLongPtr = m_remoteMemory.memValue
End Property
#If VBA7 Then
Public Property Let MemLongPtr(ByVal memAddress As LongPtr, ByVal newValue As LongPtr)
#Else
Public 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 If
End 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 With
End 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 = newValue
End Property

#If VBA7 Then
Public Function UnsignedAddition(ByVal val1 As LongPtr, ByVal val2 As LongPtr) As LongPtr
#Else
Public 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 If
Exit Function
ErrorHandler:
    Err.Raise 6, MODULE_NAME & ".UnsignedAddition", "Overflow"
End Function

Demo

For demos that are testing speed go to the Demo 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 Then
Private Sub DemoByRefLongLong()
    Dim ll As LongLong
    EditByRefLLVar ll, 1^
End Sub
Private 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 of LongLong (see the MemLongPtr Let property).

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

#If VBA7 Then
Public Property Let MemLongPtr(ByVal memAddress As LongPtr, ByVal newValue As LongPtr)
#Else
Public 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 If
End Property

Another approach is to write two Longs:

#If VBA7 Then
Public Property Let MemLongPtr(ByVal memAddress As LongPtr, ByVal newValue As LongPtr)
#Else
Public 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 If
End Property

#If Win64 Then
Private Function HiLong(ByVal ll As LongLong) As Long
    HiLong = VBA.Int(ll / &H100000000^)
End Function
Private 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 If
End 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 the DeRefMem 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.memValue
End Property
Public Property Let MemByte(ByVal memAddress As LongPtr, ByVal newValue As Byte)
    DeRefMem m_remoteMemory, memAddress, vbByte
    LetByRef(m_remoteMemory.memValue) = newValue
End Property

Private 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 With
End Sub

and now the Function equivalent:

Public Property Get MemByte(ByVal memAddress As LongPtr) As Byte
    MemByte = DeRefMem(memAddress, vbByte).memValue
End Property
Public Property Let MemByte(ByVal memAddress As LongPtr, ByVal newValue As Byte)
    LetByRef(DeRefMem(memAddress, vbByte).memValue) = newValue
End Property

Private 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 = rm
End Function

The Function approach looks definitely more readable. The problem is that it is 2-3 times slower than the Sub 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 added VarPtrArray and UnsignedAddition)?

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 at VBA-MemoryTools.

\$\endgroup\$
2
  • \$\begingroup\$ Why is the Function slower than the Sub? \$\endgroup\$
    – Greedo
    Dec 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\$ Dec 1, 2020 at 14:28

1 Answer 1

1
\$\begingroup\$

I have a very curious result of running the demo.

-------------------- Host info --------------------
OS: Microsoft Windows NT 10.0.17763.0, x64

VBA7-x64
Host Product: Microsoft Office 2016 x64
Host Version: 16.0.4266.1001
Host Executable: EXCEL.EXE

VBA6-x32
Host Product: Microsoft Office XP x86
Host Version: 10.0.6501
Host Executable: EXCEL.EXE


Immediate output after running the demo routine.

Operation Method Times time, s / VBA6-x32 time, s / VBA7-x64
Copy <Byte> By Ref 106 0.383 0.414
Copy <Byte> By API 106 0.023 2.062
Copy <Integer> By Ref 106 0.352 0.375
Copy <Integer> By API 106 0.031 2.047
Copy <Long> By Ref 106 0.781 0.375
Copy <Long> By API 106 0.062 2.047
Copy <LongLong> By Ref 106 0.508 0.484
Copy <LongLong> By API 106 0.031 2.055
Dereferenced an Object - 106 0.156 0.188

There is a minor bug in the demo code. You have:

t = Timer
For i = 1 To LOOPS
    CopyMemory x1, x2, 1
Next i

should be

Dim ByteCount As Long
ByteCount = Len(x1)
t = Timer
For i = 1 To LOOPS
    CopyMemory x1, x2, ByteCount
Next i
\$\endgroup\$
5
  • 1
    \$\begingroup\$ Interesting. I didn't have VBA6 to test with. It seems that the API is super fast. However on VBA7 x32 I get the worst results using the API. SO, I guess for VBA7 is simply faster to use the ByRef approach instead of the API. BTW, I am due to push a faster version to GitHub next week. \$\endgroup\$ Nov 14, 2021 at 8:41
  • \$\begingroup\$ @CristianBuse, see updated comment regarding a minor bug in the demo. \$\endgroup\$
    – PChemGuy
    Nov 14, 2021 at 12:26
  • \$\begingroup\$ Thanks! I will review next week. \$\endgroup\$ Nov 14, 2021 at 13:54
  • \$\begingroup\$ Here are the results I get when running the demo. As you can see on my x32 VBA7 the API is completely unusable \$\endgroup\$ Nov 22, 2021 at 12:13
  • 1
    \$\begingroup\$ BTW, thanks for looking into this. +1 Helpful to see that VBA6 is not affected. \$\endgroup\$ Nov 22, 2021 at 14:45

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.