[VB6] Dereferencing Pointers sans CopyMemory-VBForums
Results 1 to 3 of 3

Thread: [VB6] Dereferencing Pointers sans CopyMemory

  1. #1

    Thread Starter
    Default Member Bonnie West's Avatar
    Join Date
    Jun 2012
    Location
    InIDE
    Posts
    3,187

    Arrow [VB6] Dereferencing Pointers sans CopyMemory

    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 ObjSetAddRef Lib "msvbvm60.dll" Alias "__vbaObjSetAddref" (ByRef objDest As Object, ByVal pObject 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
    Private Declare Sub CopyBytes Lib "msvbvm60.dll" Alias "__vbaCopyBytes" (ByVal ByteLen As Long, ByVal Destination As Long, ByVal Source As Long)
    Private Declare Sub GetMem1 Lib "msvbvm60.dll" (ByVal Addr As Long, ByRef RetVal As Byte)
    Private Declare Sub GetMem2 Lib "msvbvm60.dll" (ByVal Addr As Long, ByRef RetVal As Integer)
    Private Declare Sub GetMem4 Lib "msvbvm60.dll" (ByVal Addr As Long, ByRef RetVal As Long)
    Private Declare Sub GetMem8 Lib "msvbvm60.dll" (ByVal Addr As Long, ByRef RetVal As Currency)
    Private Declare Sub PutMem4 Lib "msvbvm60.dll" (ByVal Addr As Long, ByVal NewVal 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
    
    





    References:

    SysAllocString/SysReAllocString functions at MSDN

    Hidden Gems for Free by Michel Rutten

    [Benchmark] CopyMemory vs. __vbaCopyBytes by Henrik Ilgen

    Using The Native Functions in VBs Runtime DLL by Voodoo Attack!!
    Last edited by Bonnie West; Nov 29th, 2014 at 05:32 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
    Declare Sub CrashVB Lib "msvbvm60" (Optional DontPassMe As Any)

  2. #2
    Hyperactive Member
    Join Date
    Jan 2010
    Posts
    442

    Re: [VB6] Dereferencing Pointers sans CopyMemory

    Thanks for sharing this.
    Last edited by Jonney; Jan 30th, 2013 at 01:05 AM.

  3. #3

    Thread Starter
    Default Member Bonnie West's Avatar
    Join Date
    Jun 2012
    Location
    InIDE
    Posts
    3,187

    Re: [VB6] Dereferencing Pointers sans CopyMemory

    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.

    Code:
    +-----------------------------------------------------------------------+
    |   10,000,000   |   1st  |   2nd  |   3rd  |   4th  |   5th  ||  Ave.  |
    |----------------+--------+--------+--------+--------+--------++--------|
    | GetBytFromPtr1 | 0.8777 | 0.8587 | 0.9396 | 0.8610 | 0.8776 || 0.8829 |
    | GetBytFromPtr2 | 0.4139 | 0.4138 | 0.3837 | 0.4139 | 0.3970 || 0.4045 |
    |                |        |        |        |        |        ||        |
    | GetIntFromPtr1 | 0.8828 | 0.8707 | 0.8657 | 0.8807 | 1.2831 || 0.9566 |
    | GetIntFromPtr2 | 0.4201 | 0.4193 | 0.4079 | 0.5599 | 0.4082 || 0.4431 |
    |                |        |        |        |        |        ||        |
    | GetLngFromPtr1 | 0.6847 | 0.6707 | 0.6707 | 1.0215 | 0.6709 || 0.7437 |
    | GetLngFromPtr2 | 0.4387 | 0.4387 | 0.3830 | 0.4475 | 0.3631 || 0.4142 |
    |                |        |        |        |        |        ||        |
    | GetCurFromPtr1 | 0.7195 | 1.0443 | 0.7087 | 0.7109 | 0.7088 || 0.7784 |
    | GetCurFromPtr2 | 0.4638 | 0.4800 | 0.3950 | 0.4926 | 0.3956 || 0.4454 |
    |----------------+--------+--------+--------+--------+--------++--------|
    | ReturnThisByt1 | 0.8593 | 0.8589 | 0.8593 | 1.1777 | 0.8732 || 0.9257 |
    | ReturnThisByt2 | 0.4078 | 0.4972 | 0.5055 | 0.4036 | 0.4067 || 0.4442 |
    |                |        |        |        |        |        ||        |
    | ReturnThisInt1 | 0.8775 | 1.1676 | 1.1693 | 0.8591 | 0.8593 || 0.9866 |
    | ReturnThisInt2 | 0.3827 | 0.3854 | 0.3827 | 0.4069 | 0.3824 || 0.3880 |
    |                |        |        |        |        |        ||        |
    | ReturnThisLng1 | 0.6896 | 0.6774 | 0.6708 | 0.6756 | 0.6710 || 0.6769 |
    | ReturnThisLng2 | 0.3827 | 0.3871 | 0.3826 | 0.4969 | 0.3824 || 0.4063 |
    |                |        |        |        |        |        ||        |
    | ReturnThisCur1 | 0.7548 | 0.7372 | 0.7215 | 1.0280 | 1.0559 || 0.8595 |
    | ReturnThisCur2 | 0.4825 | 0.4212 | 0.4176 | 0.4159 | 0.5006 || 0.4476 |
    |----------------+--------+--------+--------+--------+--------++--------|
    | GetStrFromPtr1 | 9.8013 | 9.6432 | 9.5857 | 9.5942 | 9.9817 || 9.7212 |
    | GetStrFromPtr2 | 8.7456 | 8.7415 | 8.8219 | 8.6931 | 8.6676 || 8.7339 |
    |                |        |        |        |        |        ||        |
    | GetObjFromPtr1 | 2.2159 | 2.2174 | 2.2177 | 2.2180 | 2.2173 || 2.2173 |
    | GetObjFromPtr2 | 1.1721 | 1.1706 | 1.1718 | 1.1708 | 1.1720 || 1.1715 |
    |                |        |        |        |        |        ||        |
    | GetUDTFromPtr1 | 6.6959 | 6.8592 | 6.9498 | 6.4377 | 6.9515 || 6.7788 |
    | GetUDTFromPtr2 | 7.0108 | 6.6621 | 6.8581 | 6.5292 | 6.7746 || 6.7670 |
    +-----------------------------------------------------------------------+
    
    +------------------------------------------------------------------------------------+
    |        25,000         |   1st   |   2nd   |   3rd   |   4th   |   5th   ||   Ave.  |
    |-----------------------+---------+---------+---------+---------+---------++---------|
    | CopyOverlappingMemory | 13.2884 | 13.2909 | 13.4995 | 13.1313 | 13.1234 || 13.2667 |
    | CopyOverlappingBytes  | 13.4767 | 12.9320 | 13.1654 | 13.0970 | 13.0053 || 13.1353 |
    +------------------------------------------------------------------------------------+
    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.
    Attached Files Attached Files
    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
    Declare Sub CrashVB Lib "msvbvm60" (Optional DontPassMe As Any)

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width

Survey posted by VBForums.