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.
