Here are several functions which retrieves the value or data located at the memory address specified by the given pointer. These functions perform the inverse operation of VarPtr, StrPtr and ObjPtr. Rather than using the ubiquitous CopyMemory, alternative APIs are presented instead.
The API declarations:
Code:
Private Declare Function lstrlenA Lib "kernel32.dll" (ByVal lpString As Long) As Long
Private Declare Function CopyBytes Lib "msvbvm60.dll" Alias "__vbaCopyBytes" (ByVal ByteLen As Long, ByVal Destination As Long, ByVal Source As Long) As Long
Private Declare Function GetMem1 Lib "msvbvm60.dll" (ByVal Addr As Long, ByRef RetVal As Byte) As Long
Private Declare Function GetMem2 Lib "msvbvm60.dll" (ByVal Addr As Long, ByRef RetVal As Integer) As Long
Private Declare Function GetMem4 Lib "msvbvm60.dll" (ByVal Addr As Long, ByRef RetVal As Long) As Long
Private Declare Function GetMem8 Lib "msvbvm60.dll" (ByVal Addr As Long, ByRef RetVal As Currency) As Long
Private Declare Function ObjSetAddRef Lib "msvbvm60.dll" Alias "__vbaObjSetAddref" (ByRef objDest As Object, ByVal pObject As Long) As Long
Private Declare Function PutMem4 Lib "msvbvm60.dll" (ByVal Addr As Long, ByVal NewVal As Long) As Long
Private Declare Function SysAllocString Lib "oleaut32.dll" (Optional ByVal pszStrPtr As Long) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32.dll" (Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As String
Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
The pointer dereferencing functions:
Code:
'Retrieves the Byte value from the specified memory address
Public Function GetBytFromPtr(ByVal Ptr As Long) As Byte
GetMem1 Ptr, GetBytFromPtr
End Function
'Retrieves the Integer value from the specified memory address
Public Function GetIntFromPtr(ByVal Ptr As Long) As Integer
GetMem2 Ptr, GetIntFromPtr
End Function
'Retrieves the Long value from the specified memory address
Public Function GetLngFromPtr(ByVal Ptr As Long) As Long
GetMem4 Ptr, GetLngFromPtr
End Function
'Retrieves the Currency value from the specified memory address
Public Function GetCurFromPtr(ByVal Ptr As Long) As Currency
GetMem8 Ptr, GetCurFromPtr
End Function
'Returns a copy of a null-terminated ANSI string (LPSTR/LPCSTR) from the given pointer
Public Function GetStrFromPtrA(ByVal Ptr As Long) As String
GetStrFromPtrA = SysAllocStringByteLen(Ptr, lstrlenA(Ptr))
End Function
'Returns a copy of a null-terminated Unicode string (LPWSTR/LPCWSTR) from the given pointer
Public Function GetStrFromPtrW(ByVal Ptr As Long) As String
#If WantFasterWay Then
PutMem4 VarPtr(GetStrFromPtrW), SysAllocString(Ptr)
#Else
SysReAllocString VarPtr(GetStrFromPtrW), Ptr
#End If
End Function
'Returns a counted Object reference from the given pointer
Public Function GetObjFromPtr(ByVal Ptr As Long) As Object
ObjSetAddRef GetObjFromPtr, Ptr
End Function
'Returns a shallow copy of a UDT from the given pointer (replace As UDT with the desired type)
Public Function GetUDTFromPtr(ByVal Ptr As Long) As UDT
CopyBytes LenB(GetUDTFromPtr), VarPtr(GetUDTFromPtr), Ptr
End Function
Sample usage:
Code:
'In a standard (.BAS) module
Private Type UDT 'Len LenB
'---------
Byt As Byte ' 1 4 <-- Padded so that next member is DWORD aligned
Bln As Boolean ' 2 2
Int As Integer ' 2 2
Lng As Long ' 4 4
Obj As Object ' 4 4
Sng As Single ' 4 4
Str As String ' 4 4
Cur As Currency ' 8 8
Dtm As Date ' 8 8
Dbl As Double ' 8 8
Vnt As Variant ' 16 16
FLS As String * 40 ' 40 80 <-- Unicode in memory; ANSI when written to disk
'---------
End Type '101 144
Code:
Public Sub DerefPtrs() 'Call from the Immediate Window
Dim UDT As UDT
Debug.Print
Debug.Print "GetBytFromPtr = &H"; Hex$(GetBytFromPtr(VarPtr(CByte(&HAD))))
Debug.Print "GetIntFromPtr = &H"; Hex$(GetIntFromPtr(VarPtr(&HEAD)))
Debug.Print "GetLngFromPtr = &H"; Hex$(GetLngFromPtr(VarPtr(&HADC0FFEE)))
Debug.Print "GetCurFromPtr = "; GetCurFromPtr(VarPtr(1234567890.1234@))
Debug.Print "GetStrFromPtrW = """; GetStrFromPtrW(StrPtr(App.Title)); """"
Debug.Print "GetObjFromPtr = """; GetObjFromPtr(ObjPtr(App)).Path; """"
Debug.Print
With UDT
.Byt = &HFF
.Bln = True
.Int = &H7FFF
.Lng = &H7FFFFFFF
Set .Obj = New Collection
.Sng = 3.402823E+38!
.Str = "Cwm Fjord Bank Glyphs Vext Quiz"
.Cur = 922337203685477.5807@
.Dtm = Now
.Dbl = 4.94065645841247E-324
.Vnt = CDec(7.92281625142643E+27)
.FLS = "Fix Problem Quickly With Galvanized Jets"
End With
With GetUDTFromPtr(VarPtr(UDT))
Debug.Print "Byt = &H"; Hex$(.Byt)
Debug.Print "Bln = "; .Bln
Debug.Print "Int = &H"; Hex$(.Int)
Debug.Print "Lng = &H"; Hex$(.Lng)
Debug.Print "Obj = """; TypeName(.Obj); """"
Debug.Print "Sng = "; .Sng
Debug.Print "Str = """; .Str; """"
Debug.Print "Cur = "; .Cur
Debug.Print "Dtm = "; .Dtm
Debug.Print "Dbl = "; .Dbl
Debug.Print "Vnt = "; .Vnt
Debug.Print "FLS = """; .FLS; """"
'Cleanup stolen references
PutMem4 VarPtr(.Obj), 0&
PutMem4 VarPtr(.Str), 0&
End With
End Sub
Last edited by Bonnie West; Nov 29th, 2017 at 05:59 AM.
On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
Here are the benchmark results (of the attached project below) which compares the performance of the aforementioned APIs against the general-purpose CopyMemory (a.k.a. RtlMoveMemory) API. Function names that ends in 1 uses CopyMemory while those that ends in 2 employs one of the alternative APIs. All times are in seconds.
Judging from the above table, it appears that most of the alternative APIs perform the same task slightly faster than does CopyMemory. The only exception is with the CopyBytes (a.k.a. __vbaCopyBytes) API. It shouldn't be surprising though since, except for their parameter order, they basically work the same way. Their only difference, it seems, is in the way they handle overlapping blocks of memory. CopyBytes doesn't appear to take into account overlapping blocks when copying memory and thus corrupts data when going forward. CopyMemory, on the other hand, was designed to correctly handle this issue. That's most likely the reason for its slightly slower performance compared to the other APIs. Overlapping blocks of memory aren't usually encountered in the typical cases of memory copying, so for those interested in optimizing for speed, it would probably be better to call one or more of the relevant APIs shown above instead of the all-around CopyMemory API.
On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
Public Function GetStrFromPtrA(ByVal Ptr As Long) As String
GetStrFromPtrA = SysAllocStringByteLen(Ptr, lstrlenA(Ptr))
End Function
Given your declaration does VB know to SysFreeString the BSTR returned by SysAllocStringByteLen, after it's Coverted to Unicode and copied to a new String? I can't help but think there's an inherent memory leak here. BSTR leaks are tough to track down considering OLE buffers String Allocation/Deallocation.
... does VB know to SysFreeString the BSTR returned by SysAllocStringByteLen, after it's Coverted to Unicode and copied to a new String?
It apparently does:
Code:
Option Explicit
Private Declare Function lstrlenA Lib "kernel32.dll" (ByVal lpString As Long) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32.dll" (Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As String
Private WithEvents cmdSmallBSTR As VB.CommandButton
Private WithEvents cmdLargeBSTR As VB.CommandButton
Private WithEvents cmdFreeBSTR As VB.CommandButton
Private m_BSTR As String
Private Sub cmdFreeBSTR_Click()
m_BSTR = vbNullString
Caption = """" & m_BSTR & """"
End Sub
Private Sub cmdLargeBSTR_Click()
Dim I As Long, T As Single, Spaces As String
T = Timer
Spaces = Space$(&H100000) '2 MB
For I = 1& To 1000&
m_BSTR = GetStrFromPtrA(StrPtr(StrConv(Spaces & CStr(I), vbFromUnicode)))
Next
T = Timer - T
Caption = """..." & Right$(m_BSTR, 10&) & """"
MsgBox T & " seconds", vbInformation
End Sub
Private Sub cmdSmallBSTR_Click()
Dim I As Long, T As Single
T = Timer
For I = 1& To 1000000
m_BSTR = GetStrFromPtrA(StrPtr(StrConv(CStr(I), vbFromUnicode)))
Next
T = Timer - T
Caption = """" & m_BSTR & """"
MsgBox T & " seconds", vbInformation
End Sub
Private Sub Form_Load()
Set cmdSmallBSTR = Controls.Add("VB.CommandButton", "cmdSmallBSTR")
Set cmdLargeBSTR = Controls.Add("VB.CommandButton", "cmdLargeBSTR")
Set cmdFreeBSTR = Controls.Add("VB.CommandButton", "cmdFreeBSTR")
cmdSmallBSTR.Caption = "&Small BSTR": cmdSmallBSTR.Visible = True
cmdLargeBSTR.Caption = "&Large BSTR": cmdLargeBSTR.Visible = True
cmdFreeBSTR.Caption = "&Free BSTR": cmdFreeBSTR.Visible = True
ScaleMode = vbPixels
End Sub
Private Sub Form_Resize()
Const GAP = 5!, HALF = 0.5!
Dim sngWidth As Single, sngTop As Single
On Error Resume Next
sngWidth = cmdSmallBSTR.Width
sngTop = (ScaleHeight - cmdSmallBSTR.Height) * HALF
cmdSmallBSTR.Move (ScaleWidth - (sngWidth * 3! + GAP * 2!)) * HALF, sngTop
cmdLargeBSTR.Move cmdSmallBSTR.Left + sngWidth + GAP, sngTop
cmdFreeBSTR.Move cmdLargeBSTR.Left + sngWidth + GAP, sngTop
End Sub
Private Function GetStrFromPtrA(ByVal Ptr As Long) As String
GetStrFromPtrA = SysAllocStringByteLen(Ptr, lstrlenA(Ptr))
End Function
Maybe someone who has sufficient experience in disassembling VB6 code can present a more conclusive proof...
On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
That's awesome. I would think the runtime would check where the "String" is being returned from and do either a LocalFree or a SysFreeString for OLEAUTO APIs.
Would hate to bug Trick or someone else but my curiosity may force my hand.
Option Explicit
Private Declare Function GetCommandLine Lib "kernel32" Alias "GetCommandLineA" () As Long
Private Sub Form_Load()
Dim z As String
z = GetStrFromPtrA(GetCommandLine)
End Sub
The code that is located in the GetStrFromPtrA:
This code cleans all temporary strings and returns BSTR result. You should only care for cleaning of the obtained ANSI pointer.
On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
I want to test dereferencing pointers using GetMemx v RtlMoveMemory as the benchmarks suggest a considerable performance improvement.
I wanted to add the following clarfication to my 1st post, but couldn't see how to edit:
I am running VBA7 on Windows 8.1 64-bit - when I try to add a reference to c:\Windows\SysWOW64\msvbvm60.dll I get the following error: "Name conflicts with existing module, project or object library".
1. Installed 32-bit Office, run a comparison of GetMemx versus CopyMemory and confirmed that GetMem completes in roughly half the time - 344msec v 580msec. The bare loop takes 120msec so GetMemx took 224 and CopyMemory 460 respectively.
2. Re-installed 64-bit Office, ran the same test (a for loop) using CopyMemory and saw this take 14440 msec !! Repeated the test several times, re-booted the computer and still the same amount of time give or take a few msecs.
Any idea why CopyMemory/RtlMoveMemory would so much slower in 64-bit Office?
You can compile your own version of GetMemX in a 64bit dll if you really want, but i suspect 64bit office is just slow calling APIs.
This is just one of the many reasons corporate IT dept's use 32bit office as a standard.
edit: post your code, and I bet we can speed it up. Also I bet you can get Array Mapping working in 64bit VBA.
edit 2: I've attached my AryMap Class, for use in VBA. No guarantees but it should work in 64bit VBA as well.
Since you can't use the typelib, you'll need the following API's.
I don't know of an equivelent 64bit VarPtrStringArray() function, but VarPtrArray should work with all other array types.
I've also shown how to spoof the underlying pointers of ByRef parameters.
Should be enough food for thought.
edit 3: It seems MS has fixed / removed the automatic unicode to ansi conversion when grabbing the pointer to an Array Variable. slightly jealous
Code:
Option Compare Database
Option Explicit
Public Declare PtrSafe Function Ref Lib "vbe7" Alias "VarPtr" (ByRef Ptr As Any) As LongPtr
Public Declare PtrSafe Function RefAry Lib "vbe7" Alias "VarPtr" (ByRef Var() As Any) As LongPtr
Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As LongPtr)
Public Const vbNullPtr As LongPtr = 0&
Public Property Get DeRef(ByVal Address As LongPtr) As LongPtr
CopyMemory DeRef, ByVal Address, LenB(DeRef)
End Property
Public Property Let DeRef(ByVal Address As LongPtr, ByVal Value As LongPtr)
CopyMemory ByVal Address, Value, LenB(Value)
End Property
Sub Testing(Optional ByVal Dummy As LongPtr, _
Optional ByRef Mem2 As Integer, _
Optional ByRef Mem4 As Long)
Dim s As String: s = "TEST STRING. "
Dim s2 As String: s2 = "The Answer is "
Dim Chars() As Integer
With AryMap(RefAry(Chars), StrPtr(s), 2, 32, 1) ' 32 is an arbitrary length...
Chars(5) = AscW("_")
Chars(9) = AscW("!")
.BasePtr = StrPtr(s2)
Chars(15) = AscW(":")
End With
Dim MyLong As Long
MyLong = 7
Dim Ptr(1 To 2) As LongPtr ' You can use a whole array of pointers and do a single CopyMem, to lessen the API overhead
Ptr(1) = StrPtr(s) + LenB(Mem2) * (4 - 1) ' Reference to 4th Character
Ptr(2) = Ref(MyLong)
'Copy pointers to stack
CopyMemory ByVal Ref(Dummy) + LenB(Dummy), Ptr(1), LenB(Dummy) * UBound(Ptr)
Mem2 = AscW("#")
Mem4 = Mem4 * 6
MsgBox s & s2 & MyLong
End Sub
Sub Testing2()
Testing
End Sub
Last edited by DEXWERX; May 1st, 2017 at 10:50 AM.
Hi
I need to copy 2D arrays of singles from one variable to another.
With CopyMemory I have no problems and I know how.
I wonder if it can be done with GetMem4 (PutMem4) in order to speed up the operation.
Or more generally is it possible to copy an array faster than copymemory?
how to use SetStrToPtr(string1 as string,Ptr as long) by heap?
Code:
Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Public Function GetStrFromPtrw(ByVal Ptr As Long) As String
'GOOD
SysReAllocString VarPtr(GetStrFromPtrw), Ptr
End Function
Function NewStringPtr(Str1 As String) As Long
'把字符串存到堆内存里
Dim Ptr As Long, Size As Long
Size = LenB(Str1) + 6 '4字节长度+2字节空白
Ptr = HeapAlloc(GetProcessHeap, HEAP_NO_SERIALIZE, Size)
memcpy ByVal Ptr, ByVal StrPtr(Str1) - 4, LenB(Str1) + 6 '多加2字节
NewStringPtr = Ptr
End Function
[VB6] Dereferencing Pointers sans CopyMemory
Reply With Quote
Originally Posted by DEXWERX
