dcsimg
Results 1 to 30 of 30

Thread: AddressOf Function in a Class Module

  1. #1

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    AddressOf Function in a Class Module

    Hi all,

    I want to use the SetTimer API in a class module and keep the timer callback function inside the class module.

    In order to get the actual timer function address, my thinking goes like this:

    1-Upon initialising the class, get the address of the Iunknown interface of the class instance using CopyMemory. (Base address)

    2-Decalre the Timer callback function as Public Method of the class and make it the first Method at the top of the class module.

    3-Retrieve the callback function address ==> Base address of the class + 4*3 bytes to account for QueryInterface,AddRef and Release functions

    4- Pass this address to the SetTimer function.


    Can anybody tell me what is wrong with above logic as I am trying to learn ?

    and what about if we use a 64bit process ?

    Regards.

  2. #2
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    1,544

    Re: AddressOf Function in a Class Module

    Quote Originally Posted by JAAFAR View Post
    Can anybody tell me what is wrong with above logic as I am trying to learn ?
    SetTimer API expects you to pass an address to a function (pfn) of TIMERPROC type i.e. the callback function has to have exactly these parameters:

    Code:
    void Timerproc(
      HWND Arg1,
      UINT Arg2,
      UINT_PTR Arg3,
      DWORD Arg4)
    . . . while your class method expects its this pointer (the Me in VB6 terms) to be the first argument.

    For a class method's AddressOf implementation that can be used with fire-once timers callbacks using similar to your points implementation (but working) you can check out the Modern Subclassing Thunk repo incl. the self-contained samples. Note that x64 impl is out of reach of this project yet but PRs are welcome.

    cheers,
    </wqw>

  3. #3

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    Thanks wqweto for responding.

    Question :

    I am trying to visualize this.

    If the class base address + 12 bytes is the actual memory address of the first Public Method in the class then I thought this would be the address that should be passed to the SetTimer API in its third argument.

    Is the above assumption correct ? and if so why doesn't it work ?

    I am confused. If anyone can explain this to me, I would be grateful.

    Regards.
    Last edited by JAAFAR; Jun 5th, 2019 at 07:19 AM.

  4. #4
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    1,544

    Re: AddressOf Function in a Class Module

    Quote Originally Posted by JAAFAR View Post
    If the class base address + 12 bytes is the actual memory address of the first Public Method in the class then I thought this would be the address that should be passed to the SetTimer API in its third argument.

    Is the above assumption correct ? and if so why doesn't it work ?
    VB6 interfaces/classes are IDispatch based (and there is no way to author IUnknown based interfaces, only can implement foreign IUnknown based ones) so the first public method of a class has to be at offset 7*4 in the vtbl.

    Custom UserControls and Forms have additional overhead past IDispatch members from their respective base classes (VB.UserControl and VB.Form) which is significant -- AFAR something like 400-500 additional methods.

    The AddressOfMethod thunk in MST creates a surrogate vtbl with 2048 dynamicly generated methods w/ each method just returning it's index in the vtbl so that this index can be used w/ the original vtbl to retrieve method's address from.

    cheers,
    </wqw>

  5. #5

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    @wqweto

    Thanks.

    VB6 classes Being Dispatch based, one would then think it should work by passing the memory address at offset 7*4 in the vtbl - Right ?

    This asm-like code dealing with registers looks daunting to me and I don't understand it... Do you know of any reading material that explains this for VB coders ?

    Regards.

  6. #6
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    1,544

    Re: AddressOf Function in a Class Module

    FYI, just pushed a self-contained timers sample in aeb3a16 commit. The sample frmWaitCompletion form has an API timer and does not depend on any standard module for the TimerProc.

    cheers,
    </wqw>

  7. #7

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    Quote Originally Posted by wqweto View Post
    FYI, just pushed a self-contained timers sample in aeb3a16 commit. The sample frmWaitCompletion form has an API timer and does not depend on any standard module for the TimerProc.

    cheers,
    </wqw>

    Thanks.

    Would that timer work in 64bit ?
    Would the STR_THUNK string and THUNK_SIZE need changing for 64bit ?

  8. #8

  9. #9
    Frenzied Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    1,544

    Re: AddressOf Function in a Class Module

    I didn't test MST under x64 because the "Generate x64 binary" option is disabled in my VB6 project settings dialog. . . :trollface:

    But most certainly x86 thunks are not going to be runnable in an x64 process so these will need a complete re-write.

    cheers,
    </wqw>

  10. #10

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    @The trick

    I see that the source code for the test makes use of the MSVBVM60.DLL which I don't have (and can't use) .

    In fact, I am wanting to adapt your code for VBA 32bit as well as VBA 64bit so I am not sure your code will work as is at the moment.. Using dlls other than windows native\core dlls is out of the question .

    Regards.

    EDIt:

    The class code also uses the MSVBVM60.DLL.
    Last edited by JAAFAR; Jun 5th, 2019 at 10:07 AM.

  11. #11

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    Quote Originally Posted by wqweto View Post
    I didn't test MST under x64 because the "Generate x64 binary" option is disabled in my VB6 project settings dialog. . . :trollface:

    But most certainly x86 thunks are not going to be runnable in an x64 process so these will need a complete re-write.

    cheers,
    </wqw>
    That's unfortunate .

    Thanks anyway.

    Can you (or someone else here) suggest some reading material that explains this "THUNKING" technique in VB in a more detailed manner ?

  12. #12
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,352

    Re: AddressOf Function in a Class Module

    But most certainly x86 thunks are not going to be runnable in an x64 process so these will need a complete re-write.
    I made x64 calling from VB6 to go to 64 bit mode using "heavens gate":
    Code:
    Option Explicit
    
    Private Const ProcessBasicInformation As Long = 0
    Private Const MEM_RESERVE             As Long = &H2000&
    Private Const MEM_COMMIT              As Long = &H1000&
    Private Const MEM_RELEASE             As Long = &H8000&
    Private Const PAGE_READWRITE          As Long = 4&
    Private Const FADF_AUTO               As Long = 1
    Private Const PAGE_EXECUTE_READWRITE  As Long = &H40&
    
    Private Type SAFEARRAYBOUND
        cElements                       As Long
        lLbound                         As Long
    End Type
    
    Private Type SAFEARRAY
        cDims                           As Integer
        fFeatures                       As Integer
        cbElements                      As Long
        cLocks                          As Long
        pvData                          As Long
        Bounds                          As SAFEARRAYBOUND
    End Type
    
    Private Type LARGE_INTEGER
        lowpart                         As Long
        highpart                        As Long
    End Type
    
    Private Type UNICODE_STRING64
        Length                          As Integer
        MaxLength                       As Integer
        lPad                            As Long
        lpBuffer                        As LARGE_INTEGER
    End Type
    
    Private Type IMAGE_DATA_DIRECTORY
        VirtualAddress                  As Long
        Size                            As Long
    End Type
    
    Private Type PROCESS_BASIC_INFORMATION64
        ExitStatus                      As Long
        Reserved0                       As Long
        PebBaseAddress                  As LARGE_INTEGER
        AffinityMask                    As LARGE_INTEGER
        BasePriority                    As Long
        Reserved1                       As Long
        uUniqueProcessId                As LARGE_INTEGER
        uInheritedFromUniqueProcessId   As LARGE_INTEGER
    End Type
    
    Private Type QUOTA_LIMITS64
        PagedPoolLimit                  As LARGE_INTEGER
        NonPagedPoolLimit               As LARGE_INTEGER
        MinimumWorkingSetSize           As LARGE_INTEGER
        MaximumWorkingSetSize           As LARGE_INTEGER
        PagefileLimit                   As LARGE_INTEGER
        TimeLimit                       As LARGE_INTEGER
    End Type
    
    Private Declare Function NtWow64QueryInformationProcess64 Lib "ntdll" ( _
                             ByVal hProcess As Long, _
                             ByVal ProcessInformationClass As Long, _
                             ByRef pProcessInformation As Any, _
                             ByVal uProcessInformationLength As Long, _
                             ByRef puReturnLength As Long) As Long
    Private Declare Function NtWow64ReadVirtualMemory64 Lib "ntdll" ( _
                             ByVal hProcess As Long, _
                             ByVal BaseAddressL As Long, _
                             ByVal BaseAddressH As Long, _
                             ByRef Buffer As Any, _
                             ByVal BufferLengthL As Long, _
                             ByVal BufferLengthH As Long, _
                             ByRef ReturnLength As LARGE_INTEGER) As Long
    Private Declare Function GetMem8 Lib "msvbvm60" ( _
                             ByRef Src As Any, _
                             ByRef Dst As Any) As Long
    Private Declare Function GetMem4 Lib "msvbvm60" ( _
                             ByRef Src As Any, _
                             ByRef Dst As Any) As Long
    Private Declare Function GetMem2 Lib "msvbvm60" ( _
                             ByRef Src As Any, _
                             ByRef Dst As Any) As Long
    Private Declare Function GetMem1 Lib "msvbvm60" ( _
                             ByRef Src As Any, _
                             ByRef Dst As Any) As Long
    Private Declare Function VirtualAlloc Lib "kernel32" ( _
                             ByVal lpAddress As Long, _
                             ByVal dwSize As Long, _
                             ByVal flAllocationType As Long, _
                             ByVal flProtect As Long) As Long
    Private Declare Function VirtualFree Lib "kernel32" ( _
                             ByVal lpAddress As Long, _
                             ByVal dwSize As Long, _
                             ByVal dwFreeType As Long) As Long
    Private Declare Function DispCallFunc Lib "oleaut32.dll" ( _
                             ByRef pvInstance As Any, _
                             ByVal oVft As Long, _
                             ByVal cc As Long, _
                             ByVal vtReturn As VbVarType, _
                             ByVal cActuals As Long, _
                             ByRef prgvt As Any, _
                             ByRef prgpvarg As Any, _
                             ByRef pvargResult As Variant) As Long
    Private Declare Sub MoveArray Lib "msvbvm60" _
                        Alias "__vbaAryMove" ( _
                        ByRef Destination() As Any, _
                        ByRef Source As Any)
                        
    Private mtProcessInfo64             As PROCESS_BASIC_INFORMATION64
    Private mpfnNtAllocateVirtualMemory As LARGE_INTEGER
    Private mpCode                      As Long
    
    Private Sub Form_Load()
        Dim lStatus                     As Long
        Dim tQuota                      As QUOTA_LIMITS64
        Dim lRet                        As Long
        Dim pfnNtSetInformationProcess  As LARGE_INTEGER
        
        lStatus = NtWow64QueryInformationProcess64(-1, ProcessBasicInformation, mtProcessInfo64, Len(mtProcessInfo64), 0)
        
        If lStatus < 0 Then
            MsgBox "Error 0x" & Hex$(lStatus)
            Exit Sub
        End If
        
        mpfnNtAllocateVirtualMemory = GetProcAddress64(GetNtDll_Handle, "NtAllocateVirtualMemory")
        pfnNtSetInformationProcess = GetProcAddress64(GetNtDll_Handle, "NtQueryInformationProcess")
        
        mpCode = VirtualAlloc(0, 4096, MEM_COMMIT Or MEM_RESERVE, PAGE_EXECUTE_READWRITE)
        
        Dim cA1 As Currency
        Dim cA2 As Currency
        Dim tRet    As LARGE_INTEGER
        
        GetMem4 VarPtr(tQuota), cA1
        GetMem4 VarPtr(tRet), cA2
        
        lRet = CallX64(pfnNtSetInformationProcess, -0.0001@, 0.0001@, cA1, CCur(Len(tQuota) / 10000@), cA2)
        
        pfnNtSetInformationProcess = GetProcAddress64(GetNtDll_Handle, "NtSetInformationProcess")
        
        tQuota.MaximumWorkingSetSize.highpart = -1
        tQuota.MaximumWorkingSetSize.lowpart = -1
        
        tQuota.MinimumWorkingSetSize.highpart = -1
        tQuota.MinimumWorkingSetSize.lowpart = -1
        
        lRet = CallX64(pfnNtSetInformationProcess, -0.0001@, 0.0001@, cA1, CCur(Len(tQuota) / 10000@))
        
        AllocMemory &H1FFFFFF, 0
        
    End Sub
    
    Private Sub AllocMemory( _
                ByVal lSizeL As Long, _
                ByVal lSizeH As Long)
        Dim pAddress    As LARGE_INTEGER
        Dim ppAddress   As LARGE_INTEGER
        Dim cppAddress  As Currency
        Dim cpSize      As Currency
        
        ppAddress.lowpart = VarPtr(pAddress):   GetMem8 ppAddress, cppAddress
        GetMem8 VarPtr(lSizeL), cpSize
        
        CallX64 mpfnNtAllocateVirtualMemory, -0.0001@, cppAddress, 0@, cpSize, MEM_COMMIT Or MEM_RESERVE, PAGE_READWRITE
        
    End Sub
    
    ' // Call x64
    Private Function CallX64( _
                     ByRef pfn As LARGE_INTEGER, _
                     ParamArray vArgs() As Variant) As Long
        Dim bCode()     As Byte
        Dim vArg        As Variant
        Dim lIndex      As Long
        Dim lByteIdx    As Long
        Dim lArgs       As Long
        Dim tArrDesc    As SAFEARRAY
        Dim vRet        As Variant
        
        tArrDesc.cbElements = 1
        tArrDesc.cDims = 1
        tArrDesc.fFeatures = FADF_AUTO
        tArrDesc.Bounds.cElements = 4096
        tArrDesc.pvData = mpCode
        
        MoveArray bCode(), VarPtr(tArrDesc)
        
        ' // Make x64call
        
        ' // JMP FAR 33:ADDR
        bCode(0) = &HEA
        
        GetMem4 mpCode + 7, bCode(1)
        GetMem2 &H33, bCode(5)
        
        lByteIdx = 7
        
        ' // SUB RSP, 0x28 + Args
    
        If UBound(vArgs) > 3 Then
        
            lArgs = UBound(vArgs) - 3
             lArgs = (lArgs - (lArgs \ 2) * 2) + (lArgs \ 2) * 2
            
        End If
        
        lArgs = lArgs * &H10 + &H28
        
        GetMem4 &HEC8348, bCode(lByteIdx):  lByteIdx = lByteIdx + 3
        GetMem1 lArgs, bCode(lByteIdx):     lByteIdx = lByteIdx + 1
        
        For Each vArg In vArgs
            
            Select Case VarType(vArg)
            Case vbLong
    
                Select Case lIndex
                Case 0: GetMem4 &HC1C748, bCode(lByteIdx):  lByteIdx = lByteIdx + 3
                Case 1: GetMem4 &HC2C748, bCode(lByteIdx):  lByteIdx = lByteIdx + 3
                Case 2: GetMem4 &HC0C749, bCode(lByteIdx):  lByteIdx = lByteIdx + 3
                Case 3: GetMem4 &HC1C749, bCode(lByteIdx):  lByteIdx = lByteIdx + 3
                Case Else
                
                    GetMem4 &H2444C748, bCode(lByteIdx):    lByteIdx = lByteIdx + 4
                    GetMem1 (lIndex - 4) * 8 + &H20, bCode(lByteIdx):   lByteIdx = lByteIdx + 1
    
                End Select
                
                GetMem4 CLng(vArg), bCode(lByteIdx):    lByteIdx = lByteIdx + 4
                
            Case vbCurrency
            
                Select Case lIndex
                Case 0: GetMem2 &HB948, bCode(lByteIdx):  lByteIdx = lByteIdx + 2
                Case 1: GetMem2 &HBA48, bCode(lByteIdx):  lByteIdx = lByteIdx + 2
                Case 2: GetMem2 &HB849, bCode(lByteIdx):  lByteIdx = lByteIdx + 2
                Case 3: GetMem2 &HB949, bCode(lByteIdx):  lByteIdx = lByteIdx + 2
                Case Else
                
                    GetMem2 &HB848, bCode(lByteIdx):      lByteIdx = lByteIdx + 2
                    GetMem8 CCur(vArg), bCode(lByteIdx):  lByteIdx = lByteIdx + 8
                    GetMem4 &H24448948, bCode(lByteIdx):  lByteIdx = lByteIdx + 4
                    GetMem1 (lIndex - 4) * 8 + &H20, bCode(lByteIdx):   lByteIdx = lByteIdx + 1
                    
                End Select
                
                If lIndex < 4 Then
                    GetMem8 CCur(vArg), bCode(lByteIdx):  lByteIdx = lByteIdx + 8
                End If
                
            End Select
            
            lIndex = lIndex + 1
            
        Next
        
        ' // MOV RAX, pfn: CALL RAX
        GetMem2 &HB848, bCode(lByteIdx):    lByteIdx = lByteIdx + 2
        GetMem8 pfn, bCode(lByteIdx):       lByteIdx = lByteIdx + 8
        GetMem2 &HD0FF&, bCode(lByteIdx):   lByteIdx = lByteIdx + 2
        
        ' // ADD RSP, 0x28 + Args
        GetMem4 &HC48348, bCode(lByteIdx):  lByteIdx = lByteIdx + 3
        GetMem1 lArgs, bCode(lByteIdx):     lByteIdx = lByteIdx + 1
        
        ' // JMP FAR 23:ADDR
        GetMem2 &H2DFF, bCode(lByteIdx):    lByteIdx = lByteIdx + 2
        GetMem4 0&, bCode(lByteIdx):        lByteIdx = lByteIdx + 4
        GetMem4 mpCode + lByteIdx + 6, bCode(lByteIdx):        lByteIdx = lByteIdx + 4
        GetMem2 &H23&, bCode(lByteIdx):     lByteIdx = lByteIdx + 2
    
        bCode(lByteIdx) = &HC3
        
        Debug.Print Hex(VarPtr(bCode(0)))
        
        DispCallFunc ByVal 0&, mpCode, 4, vbLong, 0, ByVal 0&, ByVal 0&, vRet
    
        GetMem4 0&, Not Not bCode
        
    End Function
    
    ' // Get procedure arrdess from 64 bit dll
    Private Function GetProcAddress64( _
                     ByRef pDllBase As LARGE_INTEGER, _
                     ByRef sFunctionName As String) As LARGE_INTEGER
        Dim pNtHeaders      As LARGE_INTEGER
        Dim lRvaNtHeaders   As Long
        Dim pExportTable    As LARGE_INTEGER
        Dim tExpDir         As IMAGE_DATA_DIRECTORY
        Dim tReturned       As LARGE_INTEGER
        Dim pNames          As LARGE_INTEGER
        Dim pName           As LARGE_INTEGER
        Dim pOrdinals       As LARGE_INTEGER
        Dim pAddresses      As LARGE_INTEGER
        Dim lCount          As Long
        Dim lIndex          As Long
        Dim lOrdinal        As Long
        Dim lBase           As Long
        
        pNtHeaders = x64PtrOffset(pDllBase.lowpart, pDllBase.highpart, &H3C)
        NtWow64ReadVirtualMemory64 -1, pNtHeaders.lowpart, pNtHeaders.highpart, lRvaNtHeaders, 4, 0, tReturned
        
        pExportTable = x64PtrOffset(pDllBase.lowpart, pDllBase.highpart, lRvaNtHeaders + &H4 + &H14 + &H70)
        NtWow64ReadVirtualMemory64 -1, pExportTable.lowpart, pExportTable.highpart, tExpDir, Len(tExpDir), 0, tReturned
                
        pExportTable = x64PtrOffset(pDllBase.lowpart, pDllBase.highpart, tExpDir.VirtualAddress)
                
        With x64PtrOffset(pExportTable.lowpart, pExportTable.highpart, &H18)
            NtWow64ReadVirtualMemory64 -1, .lowpart, .highpart, lCount, Len(lCount), 0, tReturned
        End With
    
        With x64PtrOffset(pExportTable.lowpart, pExportTable.highpart, &H10)
            NtWow64ReadVirtualMemory64 -1, .lowpart, .highpart, lBase, Len(lBase), 0, tReturned
        End With
        
        With x64PtrOffset(pExportTable.lowpart, pExportTable.highpart, &H20)
            NtWow64ReadVirtualMemory64 -1, .lowpart, .highpart, pNames, 4, 0, tReturned
        End With
        
        With x64PtrOffset(pExportTable.lowpart, pExportTable.highpart, &H24)
            NtWow64ReadVirtualMemory64 -1, .lowpart, .highpart, pOrdinals, 4, 0, tReturned
        End With
        
        With x64PtrOffset(pExportTable.lowpart, pExportTable.highpart, &H1C)
            NtWow64ReadVirtualMemory64 -1, .lowpart, .highpart, pAddresses, 4, 0, tReturned
        End With
                
        pNames = x64PtrOffset(pDllBase.lowpart, pDllBase.highpart, pNames.lowpart)
        pOrdinals = x64PtrOffset(pDllBase.lowpart, pDllBase.highpart, pOrdinals.lowpart)
        pAddresses = x64PtrOffset(pDllBase.lowpart, pDllBase.highpart, pAddresses.lowpart)
        
        For lIndex = 0 To lCount - 1
            
            NtWow64ReadVirtualMemory64 -1, pNames.lowpart, pNames.highpart, pName, 4, 0, tReturned
            pName = x64PtrOffset(pDllBase.lowpart, pDllBase.highpart, pName.lowpart)
            
            If CompareAnsiString(pName, sFunctionName) = 0 Then
    
                pOrdinals = x64PtrOffset(pOrdinals.lowpart, pOrdinals.highpart, lIndex * 2)
                
                NtWow64ReadVirtualMemory64 -1, pOrdinals.lowpart, pOrdinals.highpart, lOrdinal, 2, 0, tReturned
                
                'lOrdinal = lOrdinal - lBase
                
                pAddresses = x64PtrOffset(pAddresses.lowpart, pAddresses.highpart, lOrdinal * 4)
                
                NtWow64ReadVirtualMemory64 -1, pAddresses.lowpart, pAddresses.highpart, GetProcAddress64, 4, 0, tReturned
                
                GetProcAddress64 = x64PtrOffset(pDllBase.lowpart, pDllBase.highpart, GetProcAddress64.lowpart)
                
                Exit Function
                
            End If
            
            pNames = x64PtrOffset(pNames.lowpart, pNames.highpart, 4)
            
        Next
        
    End Function
    
    ' // Get 64-bit ntdll base address
    Private Function GetNtDll_Handle() As LARGE_INTEGER
        Dim pLdrData    As LARGE_INTEGER
        Dim tReturned   As LARGE_INTEGER
        Dim pList       As LARGE_INTEGER
        Dim pDllName    As LARGE_INTEGER
    
        With x64PtrOffset(mtProcessInfo64.PebBaseAddress.lowpart, mtProcessInfo64.PebBaseAddress.highpart, &H18)
            NtWow64ReadVirtualMemory64 -1, .lowpart, .highpart, pLdrData, 8, 0, tReturned
        End With
        
        pLdrData = x64PtrOffset(pLdrData.lowpart, pLdrData.highpart, &H10)
        
        NtWow64ReadVirtualMemory64 -1, pLdrData.lowpart, pLdrData.highpart, pList, 8, 0, tReturned
    
        Do
        
            pDllName = x64PtrOffset(pList.lowpart, pList.highpart, &H58)
        
            If CompareUnicodeString64(pDllName, "ntdll.dll") = 0 Then
                
                With x64PtrOffset(pList.lowpart, pList.highpart, &H30)
                    NtWow64ReadVirtualMemory64 -1, .lowpart, .highpart, GetNtDll_Handle, 8, 0, tReturned
                End With
                
                Exit Function
                
            End If
            
            NtWow64ReadVirtualMemory64 -1, pList.lowpart, pList.highpart, pList, 8, 0, tReturned
            
        Loop Until (pList.lowpart = pLdrData.lowpart And pList.highpart = pLdrData.highpart)
        
    End Function
    
    Private Function CompareAnsiString( _
                     ByRef pStr1 As LARGE_INTEGER, _
                     ByRef sStr2 As String) As Long
        Dim sString     As String
        Dim bString()   As Byte
        Dim tReturned   As LARGE_INTEGER
        
        ReDim bString(Len(sStr2))
        
        NtWow64ReadVirtualMemory64 -1, pStr1.lowpart, pStr1.highpart, bString(0), Len(sStr2) + 1, 0, tReturned
         
        If bString(Len(sStr2)) <> 0 Then
        
            CompareAnsiString = -1
            Exit Function
            
        End If
        
        sString = Left$(StrConv(bString, vbUnicode), Len(sStr2))
        
        CompareAnsiString = StrComp(sString, sStr2, vbBinaryCompare)
        
    End Function
    
    Private Function CompareUnicodeString64( _
                     ByRef pStr1 As LARGE_INTEGER, _
                     ByRef sStr2 As String) As Long
        Dim tString     As UNICODE_STRING64
        Dim sString     As String
        Dim tReturned   As LARGE_INTEGER
        
        NtWow64ReadVirtualMemory64 -1, pStr1.lowpart, pStr1.highpart, tString, Len(tString), 0, tReturned
        
        sString = Space$(tString.Length \ 2)
        
        NtWow64ReadVirtualMemory64 -1, tString.lpBuffer.lowpart, tString.lpBuffer.highpart, _
                                        ByVal StrPtr(sString), tString.Length - 1, 0, tReturned
        
        Debug.Print sString
        
        CompareUnicodeString64 = StrComp(sString, sStr2, vbTextCompare)
        
    End Function
    
    Private Function x64PtrOffset( _
                     ByVal pL As Long, _
                     ByVal pH As Long, _
                     ByVal lOffsetL As Long, _
                     Optional ByVal lOffsetH As Long) As LARGE_INTEGER
        Dim cValue  As Currency
        Dim cOffset As Currency
        
        GetMem8 pL, cValue
        GetMem8 lOffsetL, cOffset
        
        cValue = cValue + cOffset
        
        GetMem8 cValue, x64PtrOffset
        
    End Function
    
    
    Private Sub Form_Unload(Cancel As Integer)
        VirtualFree mpCode, 0, MEM_RELEASE
    End Sub
    The class code also uses the MSVBVM60.DLL.
    You can replace GetMem4 by RtlMoveMemory.

  13. #13

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    @The trick

    You can replace GetMem4 by RtlMoveMemory
    What about the vbaObjSetAddref function ?!

  14. #14

  15. #15

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    Quote Originally Posted by The trick View Post
    The classes don't use that. Also for vba you should remove IDE checking.
    But it is used in the form code:

    Code:
    Private Sub HookClass_WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
        Dim cmd As CommandButton
        Select Case Msg
        Case WM_MOUSELEAVE                  ' Мышь вышла за пределы контрола
            vbaObjSetAddref cmd, GetWindowLong(hwnd, GWL_USERDATA)
            cmd.FontUnderline = False
            DefCall = True
        Case WM_MOUSEMOVE
            Dim tme As tagTRACKMOUSEEVENT
            vbaObjSetAddref cmd, GetWindowLong(hwnd, GWL_USERDATA)
            tme.cbSize = Len(tme)
            tme.dwFlags = TME_QUERY
            TrackMouseEvent tme
            If tme.hwndTrack <> hwnd Then
                tme.dwFlags = TME_LEAVE     ' Мышь вошла в контрол
                tme.hwndTrack = hwnd
                TrackMouseEvent tme
                cmd.FontUnderline = True
            End If
            DefCall = True
        Case Else: DefCall = True
        End Select
    End Sub

  16. #16
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,352

    Re: AddressOf Function in a Class Module

    Quote Originally Posted by JAAFAR View Post
    But it is used in the form code:

    Code:
    Private Sub HookClass_WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, Ret As Long, DefCall As Boolean)
        Dim cmd As CommandButton
        Select Case Msg
        Case WM_MOUSELEAVE                  ' Мышь вышла за пределы контрола
            vbaObjSetAddref cmd, GetWindowLong(hwnd, GWL_USERDATA)
            cmd.FontUnderline = False
            DefCall = True
        Case WM_MOUSEMOVE
            Dim tme As tagTRACKMOUSEEVENT
            vbaObjSetAddref cmd, GetWindowLong(hwnd, GWL_USERDATA)
            tme.cbSize = Len(tme)
            tme.dwFlags = TME_QUERY
            TrackMouseEvent tme
            If tme.hwndTrack <> hwnd Then
                tme.dwFlags = TME_LEAVE     ' Мышь вошла в контрол
                tme.hwndTrack = hwnd
                TrackMouseEvent tme
                cmd.FontUnderline = True
            End If
            DefCall = True
        Case Else: DefCall = True
        End Select
    End Sub
    You should use V.2.2.

  17. #17

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    Quote Originally Posted by The trick View Post
    You should use V.2.2.
    Ok- Thanks.

    But CreateAsm, CreateStackConv and CreateIDEStub etc will need to be modifyed for x64bit as I am using VBA x64.

  18. #18
    PowerPoster Arnoutdv's Avatar
    Join Date
    Oct 2013
    Posts
    3,596

    Re: AddressOf Function in a Class Module

    You should post in Office sub forum instead of VB6 forum

  19. #19
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,352

    Re: AddressOf Function in a Class Module

    But CreateAsm, CreateStackConv and CreateIDEStub etc will need to be modifyed for x64bit as I am using VBA x64.
    Yes.
    For VBA you should also change CreateIDEStub in x86 mode too because VBA doesn't export EbMode function. You should get this function using the next method (for 32-bit office):
    Code:
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    
    Public Function GetEbMode32() As Long
        Dim pThunk  As Long
        
        pThunk = GetValue(AddressOf GetValue)
        
        CopyMemory GetEbMode32, ByVal pThunk + &HA, 4
        
        Debug.Print Hex(GetEbMode32)
        
    End Function
    
    Private Function GetValue( _
                     ByVal lValue As Long) As Long
        GetValue = lValue
    End Function
    I don't know how to get it in x64 office because i don't have this one but i'll install and check it. Then i'll show you how to modify that proc.

  20. #20
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,376

    Re: AddressOf Function in a Class Module

    IMO, such stuff (for VB6/VBA) belongs into a combination of a Class and a Module
    (it's only a handful of lines in each, much easier portable to e.g. 64Bit)
    Then ideally compiled into a COM-Dll in the end ... (regfree COM-Dll-Loading is not rocket-science anymore these days).

    Why everyone and his aunt is so fond of "thunking" in the VB-community, remains one of the "big, unsolved mysteries of the universe"
    (...at least to me) <shrug>

    Olaf

  21. #21

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    Quote Originally Posted by The trick View Post
    Yes.
    For VBA you should also change CreateIDEStub in x86 mode too because VBA doesn't export EbMode function. You should get this function using the next method (for 32-bit office):
    Code:
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    
    Public Function GetEbMode32() As Long
        Dim pThunk  As Long
        
        pThunk = GetValue(AddressOf GetValue)
        
        CopyMemory GetEbMode32, ByVal pThunk + &HA, 4
        
        Debug.Print Hex(GetEbMode32)
        
    End Function
    
    Private Function GetValue( _
                     ByVal lValue As Long) As Long
        GetValue = lValue
    End Function
    I don't know how to get it in x64 office because i don't have this one but i'll install and check it. Then i'll show you how to modify that proc.
    Thank you sir .

  22. #22

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    Quote Originally Posted by Schmidt View Post
    IMO, such stuff (for VB6/VBA) belongs into a combination of a Class and a Module
    (it's only a handful of lines in each, much easier portable to e.g. 64Bit)
    Then ideally compiled into a COM-Dll in the end ... (regfree COM-Dll-Loading is not rocket-science anymore these days).

    Why everyone and his aunt is so fond of "thunking" in the VB-community, remains one of the "big, unsolved mysteries of the universe"
    (...at least to me) <shrug>

    Olaf
    Hi Olaf,

    I agree but regfree COM-Dll-Loading still requires a seperate dll file which I am trying to avoid at all cost specially with office\vba where code is not compiled and portability is of prime importance ... The ideal for me would be to have the entire code self-conained within the vba project without the need for any external dependencies (tlbs,dlls etc ) except for the universal core windows ones like User32, Kernel32 etc ...

    That's the reason I am eager to learn about "thunking" . BTW, can you suggest any reading material about this "thunking" stuff so I can learn ?

    Regards.

  23. #23
    Frenzied Member
    Join Date
    Feb 2015
    Posts
    1,352

    Re: AddressOf Function in a Class Module

    This is the way to get EbMode in the 64 bit VBA:
    Code:
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    
    Public Function GetEbMode64() As LongPtr
        Dim pThunk  As LongPtr
        
        pThunk = GetValue(AddressOf GetValue)
        
        CopyMemory GetEbMode64, ByVal pThunk + &H25, 8
        
        Debug.Print Hex(GetEbMode64)
        
    End Function
    
    Private Function GetValue( _
                     ByVal lValue As LongPtr) As LongPtr
        GetValue = lValue
    End Function

  24. #24
    PowerPoster
    Join Date
    Jun 2013
    Posts
    4,376

    Re: AddressOf Function in a Class Module

    Quote Originally Posted by JAAFAR View Post
    The ideal for me would be to have the entire code self-conained within the vba project ...
    You mean, to be able to ship such an "entirely VBA-based solution" in a single *.xlsm in the end?
    If yes, where is the problem with my suggestion, to split the Timer-implementation up - into a Module and a Class (within that "VBA-Code containing Excel-File")?

    Olaf

  25. #25

  26. #26
    New Member
    Join Date
    Mar 2019
    Posts
    4

    Re: AddressOf Function in a Class Module

    Schmit, Is the trick's timer class the type of class composition you were referring too? I'm not sure i understand what exactly you where describing, it that's not it, would you be able to link me to an example?

  27. #27
    New Member
    Join Date
    Mar 2019
    Posts
    4

    Re: AddressOf Function in a Class Module

    *Schmidt (sorry)

  28. #28

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    Hi the trick,

    I have just seen this and downloded the vba class code from the link and I don't see the actual timer callback function .

    Thanks.

    EDIT:
    Sorry just saw it
    Last edited by JAAFAR; Jun 17th, 2019 at 01:23 AM.

  29. #29

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    Hi The trick,

    I have given the code a quick test but the timer event routine never gets called .

    In the ThisWorkbook Module :
    Code:
    Option Explicit
    
    Private WithEvents x  As class1
    
    Sub Test()
        Set x = New class1
        x.Interval = 1000
    End Sub
    
    Private Sub x_Tick()
        Range("a1") = Range("a1") + 1
    End Sub
    In fact when I step into the code , the code execution never gets past the line If m_pAsmThunk Then in the Interval Property ... I guess this because the m_pAsmThunk variable is always 0 ... Am I missing something ?

    Using excel x64bit

    Regards.
    Last edited by JAAFAR; Jun 17th, 2019 at 01:38 AM.

  30. #30

    Thread Starter
    Addicted Member
    Join Date
    Nov 2013
    Posts
    189

    Re: AddressOf Function in a Class Module

    Bump

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