using VbTrickThreading-master examples without the typelibs for Callback and Marshal

Quote:

---

Originally Posted by The trick

You can't use an arbitrary code if you don't initialize the DLL-project-context, particularly the API calls declared in VB6.
The proper way is to call DLLGetClassObject and then to call the exported functions when you use the ActiveX Dll project type.
I had the thoughts to make the module which add the ability to initialize a context in DLL created as Standard EXE but there are some pitfalls like when you receive DLL_PROCESS_DETACH how you uninitialize the projects-context created in the other threads.

The attached archive contains the module and several examples of usage in 3 different languages (VB6, C, PureBasic):

• Simple - just show message box in DLL;
• ShowForm - show the Form from DLL;
• CallbackThread - create a thread in DLL and then call the callback function in EXE.

Because of the code module is quite raw one i don't publish it in the CodeBank:

Code:

---

' //
' // modDllInitialize.bas - The module provides support for runtime-initization for dynamic link libraries
' // Version 2
' // © Krivous Anatoly Anatolevich (The trick), 2015-2020
' // If you want to use additional callback from DllMain use DLL_USE_DLLMAIN conditional compilation adrgument
' // with the DllEntry callback function
' //

Option Explicit

Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&
Private Const FADF_AUTO                As Long = 1
Private Const VB_MAGIC                  As Long = &H21354256
Private Const HEAP_ZERO_MEMORY          As Long = &H8
Private Const HEAP_NO_SERIALIZE        As Long = &H1
Private Const TLS_OUT_OF_INDEXES        As Long = &HFFFF&

' // Lazy GUID structure
Private Type tCurGUID
    c1          As Currency
    c2          As Currency
End Type

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 tVBHeaderString
    pNames(3)  As Long
End Type

Private Const DLL_PROCESS_ATTACH    As Long = 1
Private Const DLL_PROCESS_DETACH    As Long = 0
Private Const DLL_THREAD_ATTACH    As Long = 2
Private Const DLL_THREAD_DETACH    As Long = 3

Private mlTlsSlot  As Long    ' // Index of the item in the TLS. There will be data specific to the thread.
Private mpVbHeader  As Long    ' // Pointer to VBHeader structure.
Private mhInstance  As Long    ' // Base address of the module

' // Unused
Private Sub Main()

End Sub

' // This function is called when the module is being loaded/unloaded to a process or a thread is created/destroyed
Public Function DllMain( _
                ByVal hinstDLL As Long, _
                ByVal fdwReason As Long, _
                ByVal lpvReserved As Long) As Long

    Select Case fdwReason
    Case DLL_PROCESS_ATTACH
       
        If VBDll.UserDllMain(mhInstance, 0, hinstDLL, fdwReason, lpvReserved) = 0 Then
            GoTo CleanUp
        End If

        mlTlsSlot = VBDll.TlsAlloc()
        If mlTlsSlot = TLS_OUT_OF_INDEXES Then GoTo CleanUp
       
        DllMain = InitializeRuntimeForProject(hinstDLL, True) And 1
       
#If DLL_USE_DLLMAIN Then
        If DllMain Then
            DllMain = DllEntry(hinstDLL, fdwReason, lpvReserved)
        End If
#End If

    Case DLL_THREAD_ATTACH

        If VBDll.UserDllMain(mhInstance, 0, hinstDLL, fdwReason, lpvReserved) = 0 Then
            GoTo CleanUp
        End If

        DllMain = InitializeRuntimeForProject(hinstDLL, False) And 1

#If DLL_USE_DLLMAIN Then
        If DllMain Then
            DllMain = DllEntry(hinstDLL, fdwReason, lpvReserved)
        End If
#End If

    Case DLL_THREAD_DETACH

#If DLL_USE_DLLMAIN Then
        DllEntry hinstDLL, fdwReason, lpvReserved
#End If

        If VBDll.UserDllMain(mhInstance, 0, hinstDLL, fdwReason, lpvReserved) = 0 Then
            GoTo CleanUp
        End If

        UninitializeRuntimeForProject hinstDLL
       
        FreeHeaderForCurrentThread
       
        DllMain = 1

    Case DLL_PROCESS_DETACH

#If DLL_USE_DLLMAIN Then
        DllEntry hinstDLL, fdwReason, lpvReserved
#End If
       
        CanUnloadNowCall

        VBDll.UserDllMain mhInstance, 0, hinstDLL, fdwReason, lpvReserved
       
        FreeHeaderForCurrentThread
       
        VBDll.TlsFree mlTlsSlot

        mlTlsSlot = 0
        mpVbHeader = 0
       
        DllMain = 1
       
        Exit Function
       
    End Select
     
CleanUp:

End Function

' // Uninitialize the runime
Public Function UninitializeRuntimeForProject( _
                ByVal hInstance As Long) As Boolean
    Dim pNewHeader  As Long
   
    ' // Check if the module is initialized
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
    If pNewHeader = 0 Then Exit Function

    VBDll.CoUninitialize
   
    UninitializeRuntimeForProject = True
   
End Function

' // Free the current header
Public Function FreeHeaderForCurrentThread() As Boolean
    Dim pNewHeader  As Long
   
    ' // Check if the module is initialized
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
    If pNewHeader = 0 Then Exit Function
   
    VBDll.HeapFree VBDll.GetProcessHeap(), 0, pNewHeader
   
End Function

' // Initilaize the runtime
Public Function InitializeRuntimeForProject( _
                ByVal hInstance As Long, _
                ByVal bIsFirst As Boolean) As Boolean
    Dim pNewHeader  As Long
    Dim tClsId      As tCurGUID
    Dim tIID        As tCurGUID
    Dim lUnused    As Long
   
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
   
    ' // Check if the module already initialized
    If pNewHeader Then

        InitializeRuntimeForProject = True
        Exit Function
       
    End If
   
    VBDll.CoInitialize ByVal 0&
   
    If mpVbHeader = 0 Then
       
        ' // Search for VBHeader (EXEPROJECTINFO)
        mpVbHeader = SearchForVbHeader(hInstance)
        If mpVbHeader = 0 Then Exit Function
       
        ' // Modify header
        ModifyVBHeader
       
    End If
   
    ' // Create the new copy of headers for new instance
    pNewHeader = CreateVBHeaderCopy()
   
    ' // Save it
    VBDll.TlsSetValue mlTlsSlot, ByVal pNewHeader

    If pNewHeader = 0 Then
        Exit Function
    End If
   
    ' // IID_IUnknown
    tIID.c2 = 504403158265495.5712@
   
    ' // Call CThreadPool::InitDllAccess
    VBDll.VBDllGetClassObject hInstance, 0, pNewHeader, tClsId, tIID, 0
   
    If bIsFirst Then
        ' // Initialize App object
        lUnused = App.ThreadID
    End If
   
    InitializeRuntimeForProject = True
   
End Function

Private Sub CanUnloadNowCall()
    Dim pNewHeader  As Long
    Dim bThreading  As Byte
   
    ' // Check if the module is initialized
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
    If pNewHeader = 0 Then Exit Sub

    ' // To ensure cleaning of the project data set the threading model to the apartment one.
    VBDll.GetMem1 ByVal pNewHeader + &H3C, bThreading
    bThreading = bThreading Or 1
    VBDll.GetMem1 bThreading, ByVal pNewHeader + &H3C
   
    ' // The runtime will call CThreadPool::CheckForProjectUnload and CVBThreadAction::CleanupProjData
    If VBDll.VBDllCanUnloadNow(pNewHeader) Then
        Exit Sub
    End If

End Sub

' // Search for VBHeader(EXEPROJECTINFO)
Private Function SearchForVbHeader( _
                ByVal hInstance As Long) As Long
    Dim ptr            As Long
    Dim lSignature      As Long
    Dim pImportDesc    As Long
    Dim pStartSearch    As Long
    Dim pEndSearch      As Long
    Dim bData()        As Byte
    Dim tArrDesc        As SAFEARRAY
    Dim lIndex          As Long
   
    ' // VBHeader is placed within the end of IAT and beginning of IMAGE_IMPORT_DESCRIPTOR
   
    ' // Get e_lfanew
    VBDll.GetMem4 ByVal hInstance + &H3C, ptr
    ' // Get IAT
    VBDll.GetMem4 ByVal ptr + &H80 + hInstance, pImportDesc
   
    pEndSearch = hInstance + pImportDesc - 4
   
    Do
   
        ' // Get IMAGE_IMPORT_DESCRIPTOR.FirstThunk
        VBDll.GetMem4 ByVal pImportDesc + &H10 + hInstance, ptr
       
        If ptr > pStartSearch Then
            pStartSearch = ptr
        End If
       
        pImportDesc = pImportDesc + &H14
       
    Loop While ptr
   
    ' // Search for null-thunk (skip valid IAT entries)
    Do
       
        VBDll.GetMem4 ByVal hInstance + pStartSearch, ptr
        pStartSearch = pStartSearch + 4
       
    Loop While ptr
   
    pStartSearch = pStartSearch + hInstance
   
    If pEndSearch < pStartSearch Then Exit Function
   
    ' // Map the array to the data
    tArrDesc.cbElements = 1
    tArrDesc.cDims = 1
    tArrDesc.fFeatures = FADF_AUTO
    tArrDesc.pvData = pStartSearch
    tArrDesc.Bounds.cElements = pEndSearch - pStartSearch + 5
   
    VBDll.MoveArray bData(), VarPtr(tArrDesc)
   
    For lIndex = 0 To tArrDesc.Bounds.cElements - 5
       
        ' // __vbaS of an exe module has the following structure:
        ' // PUSH OFFSET VbHeader
        ' // CALL ThunRTMain
       
        ' // Search for PUSH IMM opcode
        If bData(lIndex) = &H68 Then
           
            ' // Get Immediate value
            VBDll.GetMem4 bData(lIndex + 1), ptr
           
            ' // Check range
            If ptr >= pStartSearch And ptr < pEndSearch Then
               
                ' // Check signature (VB5!)
                VBDll.GetMem4 ByVal ptr, lSignature
               
                If lSignature = VB_MAGIC Then
                   
                    SearchForVbHeader = ptr
                    Exit Function
                   
                End If
               
            End If
           
        End If
       
    Next
   
End Function

' // Modify VBHeader to replace Sub Main
Private Sub ModifyVBHeader()
    Dim ptr            As Long
    Dim lOldProtect    As Long
    Dim lFlags          As Long
    Dim lFormsCount    As Long
    Dim lModulesCount  As Long
    Dim lStructSize    As Long
   
    ' // Allow to write to that page
    VBDll.VirtualProtect ByVal mpVbHeader, &H64, PAGE_EXECUTE_READWRITE, lOldProtect
   
    ' // Remove Sub Main
    ptr = mpVbHeader + &H2C
    VBDll.GetMem4 0&, ByVal ptr

    VBDll.VirtualProtect ByVal mpVbHeader, &H64, lOldProtect, 0
   
    ' // Remove startup form
    VBDll.GetMem4 ByVal mpVbHeader + &H4C, ptr
    ' // Get number of forms
    VBDll.GetMem2 ByVal mpVbHeader + &H44, lFormsCount
   
    Do While lFormsCount > 0
   
        ' // Get structure size
        VBDll.GetMem4 ByVal ptr, lStructSize
       
        ' // Get flag (unknown5) from current form
        VBDll.GetMem4 ByVal ptr + &H28, lFlags
       
        ' // When set, bit 5,
        If lFlags And &H10 Then
       
            ' // Unset bit 5
            lFlags = lFlags And &HFFFFFFEF
            ' // Are allowed to write in the page
            VBDll.VirtualProtect ByVal ptr, 4, PAGE_EXECUTE_READWRITE, lOldProtect
            ' // Write changet lFlags
            VBDll.GetMem4 lFlags, ByVal ptr + &H28
            ' // Restoring the memory attributes
            VBDll.VirtualProtect ByVal ptr, 4, lOldProtect, 0
           
        End If
       
        lFormsCount = lFormsCount - 1
        ptr = ptr + lStructSize
       
    Loop

End Sub

' // Create copy of VBHeader and other structures
Private Function CreateVBHeaderCopy() As Long
    Dim pHeader        As Long
    Dim pOldProjInfo    As Long
    Dim pProjInfo      As Long
    Dim pObjTable      As Long
    Dim pOldObjTable    As Long
    Dim lDifference    As Long
    Dim lIndex          As Long
    Dim lSubIndex      As Long
    Dim tNames          As tVBHeaderString
    Dim lModulesCount  As Long
    Dim pDescriptors    As Long
    Dim pOldDesc        As Long
    Dim pVarBlock      As Long
    Dim lSizeOfHeaders  As Long
    Dim lExtCount      As Long
    Dim lNewExtCount    As Long
    Dim pOldExtApi      As Long
    Dim pExtApi        As Long
    Dim lExtFlags      As Long

    ' // Get size of all headers
    lSizeOfHeaders = &H6A + &H23C + &H54 + &HC
   
    VBDll.GetMem4 ByVal mpVbHeader + &H30, pOldProjInfo
    VBDll.GetMem4 ByVal pOldProjInfo + &H4, pOldObjTable
    VBDll.GetMem4 ByVal pOldObjTable + &H30, pOldDesc
    VBDll.GetMem2 ByVal pOldObjTable + &H2A, lModulesCount
   
    lSizeOfHeaders = lSizeOfHeaders + &H30 * lModulesCount
   
    ' // Free API external block
    VBDll.GetMem4 ByVal pOldProjInfo + &H238, lExtCount
    VBDll.GetMem4 ByVal pOldProjInfo + &H234, pOldExtApi
   
    For lIndex = 0 To lExtCount - 1
       
        VBDll.GetMem4 ByVal pOldExtApi + lIndex * 8, lExtFlags
       
        If lExtFlags <> 7 Then
            lNewExtCount = lNewExtCount + 1
        End If
       
    Next
   
    lSizeOfHeaders = lSizeOfHeaders + lNewExtCount * 8
               
    ' // Allocate memory for header
    pHeader = VBDll.HeapAlloc(VBDll.GetProcessHeap(), HEAP_ZERO_MEMORY, lSizeOfHeaders)
    If pHeader = 0 Then GoTo CleanUp

    lDifference = pHeader - mpVbHeader
   
    VBDll.CopyMemory ByVal pHeader, ByVal mpVbHeader, &H6A
   
    ' // Update strings offsets
    VBDll.CopyMemory tNames.pNames(0), ByVal mpVbHeader + &H58, &H10
   
    For lIndex = 0 To 3
        tNames.pNames(lIndex) = tNames.pNames(lIndex) - lDifference
    Next
       
    VBDll.CopyMemory ByVal pHeader + &H58, tNames.pNames(0), &H10

    ' // In order to keep global variables
    ' // Change the VbPublicObjectDescriptor.lpPublicBytes, VbPublicObjectDescriptor.lpStaticBytes
    pProjInfo = pHeader + &H6A

    VBDll.CopyMemory ByVal pProjInfo, ByVal pOldProjInfo, &H23C

    ' // Update on VBHeader
    VBDll.GetMem4 pProjInfo, ByVal pHeader + &H30

    ' // Create copy of Object table
    pObjTable = pProjInfo + &H23C

    VBDll.CopyMemory ByVal pObjTable, ByVal pOldObjTable, &H54

    ' // Update
    VBDll.GetMem4 pObjTable, ByVal pProjInfo + &H4

    ' // Allocate descriptors
    pDescriptors = pObjTable + &H54

    VBDll.CopyMemory ByVal pDescriptors, ByVal pOldDesc, lModulesCount * &H30

    ' // Update
    VBDll.GetMem4 pDescriptors, ByVal pObjTable + &H30

    ' // Allocate variables block
    pVarBlock = pDescriptors + lModulesCount * &H30

    For lIndex = 0 To lModulesCount - 1

        ' // Zero number of public and local variables
        VBDll.GetMem4 pVarBlock, ByVal pDescriptors + lIndex * &H30 + &H8
        VBDll.GetMem4 0&, ByVal pDescriptors + lIndex * &H30 + &HC

    Next
   
    ' // Free API
    pExtApi = pVarBlock + &HC
    lSubIndex = 0
   
    For lIndex = 0 To lExtCount - 1
       
        VBDll.GetMem4 ByVal pOldExtApi + lIndex * 8, lExtFlags
       
        If lExtFlags <> 7 Then
           
            VBDll.GetMem8 ByVal pOldExtApi + lIndex * 8, ByVal pExtApi + lSubIndex * 8
            lSubIndex = lSubIndex + 1
           
        End If
       
    Next
   
    ' // Update
    VBDll.GetMem4 pExtApi, ByVal pProjInfo + &H234
    VBDll.GetMem4 lNewExtCount, ByVal pProjInfo + &H238
   
    CreateVBHeaderCopy = pHeader
   
CleanUp:

End Function

---

Usage in C:

Code:

---

#include <windows.h>
#include <stdio.h>
#include <stdlib.h>
#include <time.h>
#include <initguid.h>

#include "interfaces.h"

volatile DWORD g_TlsSlot;

LONG __stdcall CallBack(IUnknown *pObj) {
        HRESULT hr;

        _Form *pForm;
        float fWidth, fHeight;

        if (FAILED(hr = pObj->lpVtbl->QueryInterface(pObj, &IID__Form, (void**)&pForm))) {
                return E_UNEXPECTED;
        }

        // Check if already initialized
        if (!TlsGetValue(g_TlsSlot)) {
                TlsSetValue(g_TlsSlot, (LPVOID)1);
                srand(time(NULL));
        }

        if (SUCCEEDED(hr = pForm->lpVtbl->get_ScaleWidth(pForm, &fWidth)) &&
                SUCCEEDED(hr = pForm->lpVtbl->get_ScaleHeight(pForm, &fHeight))) {
                hr = pForm->lpVtbl->Circle(pForm, 0, rand() % (int)fWidth, rand() % (int)fHeight, rand() % 500, 0, 0, 0, 0);
        }

        pForm->lpVtbl->Release(pForm);

        return hr;

}

int main(int argc, char **argv) {
        HINSTANCE hLib = LoadLibrary("CallbackThread.dll");
        DWORD g_TlsSlot = TlsAlloc();

        VOID (__stdcall *SetCallback)(LONG (__stdcall *)(IUnknown *)) =
                (VOID (__stdcall *)(LONG (__stdcall *)(IUnknown *)))GetProcAddress(hLib, "SetCallback");

        if (!SetCallback)
                return 1;

        SetCallback(CallBack);

        printf("press a button to exit\r\n");
        getchar();

        FreeLibrary(hLib);
        TlsFree(g_TlsSlot);

        return 0;

}

---

---

Hello the trick,

1. How is the following GUID extracted in the interfaces.h file of C based exe project for the frmThread form of the CallbackThread standard dll project.


(0x33AD4F39, 0x6699, 0x11CF, 0xB7, 0x0C, 0x00, 0xAA, 0x00, 0x60, 0xD3, 0x93);

2. Is there any way to programmatically extract GUID of any resource like form or class
in CallBackThread project.

Thanks

Quote:

---

Originally Posted by smkperu

Hello the trick,

1. How is the following GUID extracted in the interfaces.h file of C based exe project for the frmThread form of the CallbackThread standard dll project.


(0x33AD4F39, 0x6699, 0x11CF, 0xB7, 0x0C, 0x00, 0xAA, 0x00, 0x60, 0xD3, 0x93);

Thanks

---

It's VB6-Form interface.

Quote:

---

Originally Posted by The trick

It's VB6-Form interface.

---

Hello Trick,

If we had used two different forms say frmThread1 and frmThread2 in CallbackThread how are they distinguised.

Thanks

Quote:

---

Originally Posted by smkperu

Hello Trick,

If we had used two different forms say frmThread1 and frmThread2 in CallbackThread how are they distinguised.

Thanks

---

You could use Implement keyword for example.

Quote:

---

Originally Posted by The trick

You could use Implement keyword for example.

---

Hello Trick,

1. Can you show me how to do this for more than one form in CallbackThread vb6 dll and access in C based exe.

2. How to do this for vb6 Classes in addition to forms.


Thanks

Quote:

---

Originally Posted by The trick

It's VB6-Form interface.

---

Hello Trick,

Now I understood that using Guid method of InterfaceInfo object created InterfaceInfoFromObject we get guid of class or form from Typelib Information.

Like you have done in CallbackThread project can you provide a simple example of how to access a vb6 form/Class method from c application using vtbl.

Thanks

Hello Trick,

I understood that by sending IUnknown pointer of vb6 class object I was able to access it in c application using its lpvtbl.

Thanks

Hello Trick,

I am unable to send PM as your inbox is full.Please clear some messages.

Thanks

Quote:

---

Originally Posted by The trick

You can't use an arbitrary code if you don't initialize the DLL-project-context, particularly the API calls declared in VB6.
The proper way is to call DLLGetClassObject and then to call the exported functions when you use the ActiveX Dll project type.
I had the thoughts to make the module which add the ability to initialize a context in DLL created as Standard EXE but there are some pitfalls like when you receive DLL_PROCESS_DETACH how you uninitialize the projects-context created in the other threads.

The attached archive contains the module and several examples of usage in 3 different languages (VB6, C, PureBasic):

• Simple - just show message box in DLL;
• ShowForm - show the Form from DLL;
• CallbackThread - create a thread in DLL and then call the callback function in EXE.

Because of the code module is quite raw one i don't publish it in the CodeBank:

Code:

---

' //
' // modDllInitialize.bas - The module provides support for runtime-initization for dynamic link libraries
' // Version 2
' // © Krivous Anatoly Anatolevich (The trick), 2015-2020
' // If you want to use additional callback from DllMain use DLL_USE_DLLMAIN conditional compilation adrgument
' // with the DllEntry callback function
' //

Option Explicit

Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&
Private Const FADF_AUTO                As Long = 1
Private Const VB_MAGIC                  As Long = &H21354256
Private Const HEAP_ZERO_MEMORY          As Long = &H8
Private Const HEAP_NO_SERIALIZE        As Long = &H1
Private Const TLS_OUT_OF_INDEXES        As Long = &HFFFF&

' // Lazy GUID structure
Private Type tCurGUID
    c1          As Currency
    c2          As Currency
End Type

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 tVBHeaderString
    pNames(3)  As Long
End Type

Private Const DLL_PROCESS_ATTACH    As Long = 1
Private Const DLL_PROCESS_DETACH    As Long = 0
Private Const DLL_THREAD_ATTACH    As Long = 2
Private Const DLL_THREAD_DETACH    As Long = 3

Private mlTlsSlot  As Long    ' // Index of the item in the TLS. There will be data specific to the thread.
Private mpVbHeader  As Long    ' // Pointer to VBHeader structure.
Private mhInstance  As Long    ' // Base address of the module

' // Unused
Private Sub Main()

End Sub

' // This function is called when the module is being loaded/unloaded to a process or a thread is created/destroyed
Public Function DllMain( _
                ByVal hinstDLL As Long, _
                ByVal fdwReason As Long, _
                ByVal lpvReserved As Long) As Long

    Select Case fdwReason
    Case DLL_PROCESS_ATTACH
       
        If VBDll.UserDllMain(mhInstance, 0, hinstDLL, fdwReason, lpvReserved) = 0 Then
            GoTo CleanUp
        End If

        mlTlsSlot = VBDll.TlsAlloc()
        If mlTlsSlot = TLS_OUT_OF_INDEXES Then GoTo CleanUp
       
        DllMain = InitializeRuntimeForProject(hinstDLL, True) And 1
       
#If DLL_USE_DLLMAIN Then
        If DllMain Then
            DllMain = DllEntry(hinstDLL, fdwReason, lpvReserved)
        End If
#End If

    Case DLL_THREAD_ATTACH

        If VBDll.UserDllMain(mhInstance, 0, hinstDLL, fdwReason, lpvReserved) = 0 Then
            GoTo CleanUp
        End If

        DllMain = InitializeRuntimeForProject(hinstDLL, False) And 1

#If DLL_USE_DLLMAIN Then
        If DllMain Then
            DllMain = DllEntry(hinstDLL, fdwReason, lpvReserved)
        End If
#End If

    Case DLL_THREAD_DETACH

#If DLL_USE_DLLMAIN Then
        DllEntry hinstDLL, fdwReason, lpvReserved
#End If

        If VBDll.UserDllMain(mhInstance, 0, hinstDLL, fdwReason, lpvReserved) = 0 Then
            GoTo CleanUp
        End If

        UninitializeRuntimeForProject hinstDLL
       
        FreeHeaderForCurrentThread
       
        DllMain = 1

    Case DLL_PROCESS_DETACH

#If DLL_USE_DLLMAIN Then
        DllEntry hinstDLL, fdwReason, lpvReserved
#End If
       
        CanUnloadNowCall

        VBDll.UserDllMain mhInstance, 0, hinstDLL, fdwReason, lpvReserved
       
        FreeHeaderForCurrentThread
       
        VBDll.TlsFree mlTlsSlot

        mlTlsSlot = 0
        mpVbHeader = 0
       
        DllMain = 1
       
        Exit Function
       
    End Select
     
CleanUp:

End Function

' // Uninitialize the runime
Public Function UninitializeRuntimeForProject( _
                ByVal hInstance As Long) As Boolean
    Dim pNewHeader  As Long
   
    ' // Check if the module is initialized
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
    If pNewHeader = 0 Then Exit Function

    VBDll.CoUninitialize
   
    UninitializeRuntimeForProject = True
   
End Function

' // Free the current header
Public Function FreeHeaderForCurrentThread() As Boolean
    Dim pNewHeader  As Long
   
    ' // Check if the module is initialized
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
    If pNewHeader = 0 Then Exit Function
   
    VBDll.HeapFree VBDll.GetProcessHeap(), 0, pNewHeader
   
End Function

' // Initilaize the runtime
Public Function InitializeRuntimeForProject( _
                ByVal hInstance As Long, _
                ByVal bIsFirst As Boolean) As Boolean
    Dim pNewHeader  As Long
    Dim tClsId      As tCurGUID
    Dim tIID        As tCurGUID
    Dim lUnused    As Long
   
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
   
    ' // Check if the module already initialized
    If pNewHeader Then

        InitializeRuntimeForProject = True
        Exit Function
       
    End If
   
    VBDll.CoInitialize ByVal 0&
   
    If mpVbHeader = 0 Then
       
        ' // Search for VBHeader (EXEPROJECTINFO)
        mpVbHeader = SearchForVbHeader(hInstance)
        If mpVbHeader = 0 Then Exit Function
       
        ' // Modify header
        ModifyVBHeader
       
    End If
   
    ' // Create the new copy of headers for new instance
    pNewHeader = CreateVBHeaderCopy()
   
    ' // Save it
    VBDll.TlsSetValue mlTlsSlot, ByVal pNewHeader

    If pNewHeader = 0 Then
        Exit Function
    End If
   
    ' // IID_IUnknown
    tIID.c2 = 504403158265495.5712@
   
    ' // Call CThreadPool::InitDllAccess
    VBDll.VBDllGetClassObject hInstance, 0, pNewHeader, tClsId, tIID, 0
   
    If bIsFirst Then
        ' // Initialize App object
        lUnused = App.ThreadID
    End If
   
    InitializeRuntimeForProject = True
   
End Function

Private Sub CanUnloadNowCall()
    Dim pNewHeader  As Long
    Dim bThreading  As Byte
   
    ' // Check if the module is initialized
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
    If pNewHeader = 0 Then Exit Sub

    ' // To ensure cleaning of the project data set the threading model to the apartment one.
    VBDll.GetMem1 ByVal pNewHeader + &H3C, bThreading
    bThreading = bThreading Or 1
    VBDll.GetMem1 bThreading, ByVal pNewHeader + &H3C
   
    ' // The runtime will call CThreadPool::CheckForProjectUnload and CVBThreadAction::CleanupProjData
    If VBDll.VBDllCanUnloadNow(pNewHeader) Then
        Exit Sub
    End If

End Sub

' // Search for VBHeader(EXEPROJECTINFO)
Private Function SearchForVbHeader( _
                ByVal hInstance As Long) As Long
    Dim ptr            As Long
    Dim lSignature      As Long
    Dim pImportDesc    As Long
    Dim pStartSearch    As Long
    Dim pEndSearch      As Long
    Dim bData()        As Byte
    Dim tArrDesc        As SAFEARRAY
    Dim lIndex          As Long
   
    ' // VBHeader is placed within the end of IAT and beginning of IMAGE_IMPORT_DESCRIPTOR
   
    ' // Get e_lfanew
    VBDll.GetMem4 ByVal hInstance + &H3C, ptr
    ' // Get IAT
    VBDll.GetMem4 ByVal ptr + &H80 + hInstance, pImportDesc
   
    pEndSearch = hInstance + pImportDesc - 4
   
    Do
   
        ' // Get IMAGE_IMPORT_DESCRIPTOR.FirstThunk
        VBDll.GetMem4 ByVal pImportDesc + &H10 + hInstance, ptr
       
        If ptr > pStartSearch Then
            pStartSearch = ptr
        End If
       
        pImportDesc = pImportDesc + &H14
       
    Loop While ptr
   
    ' // Search for null-thunk (skip valid IAT entries)
    Do
       
        VBDll.GetMem4 ByVal hInstance + pStartSearch, ptr
        pStartSearch = pStartSearch + 4
       
    Loop While ptr
   
    pStartSearch = pStartSearch + hInstance
   
    If pEndSearch < pStartSearch Then Exit Function
   
    ' // Map the array to the data
    tArrDesc.cbElements = 1
    tArrDesc.cDims = 1
    tArrDesc.fFeatures = FADF_AUTO
    tArrDesc.pvData = pStartSearch
    tArrDesc.Bounds.cElements = pEndSearch - pStartSearch + 5
   
    VBDll.MoveArray bData(), VarPtr(tArrDesc)
   
    For lIndex = 0 To tArrDesc.Bounds.cElements - 5
       
        ' // __vbaS of an exe module has the following structure:
        ' // PUSH OFFSET VbHeader
        ' // CALL ThunRTMain
       
        ' // Search for PUSH IMM opcode
        If bData(lIndex) = &H68 Then
           
            ' // Get Immediate value
            VBDll.GetMem4 bData(lIndex + 1), ptr
           
            ' // Check range
            If ptr >= pStartSearch And ptr < pEndSearch Then
               
                ' // Check signature (VB5!)
                VBDll.GetMem4 ByVal ptr, lSignature
               
                If lSignature = VB_MAGIC Then
                   
                    SearchForVbHeader = ptr
                    Exit Function
                   
                End If
               
            End If
           
        End If
       
    Next
   
End Function

' // Modify VBHeader to replace Sub Main
Private Sub ModifyVBHeader()
    Dim ptr            As Long
    Dim lOldProtect    As Long
    Dim lFlags          As Long
    Dim lFormsCount    As Long
    Dim lModulesCount  As Long
    Dim lStructSize    As Long
   
    ' // Allow to write to that page
    VBDll.VirtualProtect ByVal mpVbHeader, &H64, PAGE_EXECUTE_READWRITE, lOldProtect
   
    ' // Remove Sub Main
    ptr = mpVbHeader + &H2C
    VBDll.GetMem4 0&, ByVal ptr

    VBDll.VirtualProtect ByVal mpVbHeader, &H64, lOldProtect, 0
   
    ' // Remove startup form
    VBDll.GetMem4 ByVal mpVbHeader + &H4C, ptr
    ' // Get number of forms
    VBDll.GetMem2 ByVal mpVbHeader + &H44, lFormsCount
   
    Do While lFormsCount > 0
   
        ' // Get structure size
        VBDll.GetMem4 ByVal ptr, lStructSize
       
        ' // Get flag (unknown5) from current form
        VBDll.GetMem4 ByVal ptr + &H28, lFlags
       
        ' // When set, bit 5,
        If lFlags And &H10 Then
       
            ' // Unset bit 5
            lFlags = lFlags And &HFFFFFFEF
            ' // Are allowed to write in the page
            VBDll.VirtualProtect ByVal ptr, 4, PAGE_EXECUTE_READWRITE, lOldProtect
            ' // Write changet lFlags
            VBDll.GetMem4 lFlags, ByVal ptr + &H28
            ' // Restoring the memory attributes
            VBDll.VirtualProtect ByVal ptr, 4, lOldProtect, 0
           
        End If
       
        lFormsCount = lFormsCount - 1
        ptr = ptr + lStructSize
       
    Loop

End Sub

' // Create copy of VBHeader and other structures
Private Function CreateVBHeaderCopy() As Long
    Dim pHeader        As Long
    Dim pOldProjInfo    As Long
    Dim pProjInfo      As Long
    Dim pObjTable      As Long
    Dim pOldObjTable    As Long
    Dim lDifference    As Long
    Dim lIndex          As Long
    Dim lSubIndex      As Long
    Dim tNames          As tVBHeaderString
    Dim lModulesCount  As Long
    Dim pDescriptors    As Long
    Dim pOldDesc        As Long
    Dim pVarBlock      As Long
    Dim lSizeOfHeaders  As Long
    Dim lExtCount      As Long
    Dim lNewExtCount    As Long
    Dim pOldExtApi      As Long
    Dim pExtApi        As Long
    Dim lExtFlags      As Long

    ' // Get size of all headers
    lSizeOfHeaders = &H6A + &H23C + &H54 + &HC
   
    VBDll.GetMem4 ByVal mpVbHeader + &H30, pOldProjInfo
    VBDll.GetMem4 ByVal pOldProjInfo + &H4, pOldObjTable
    VBDll.GetMem4 ByVal pOldObjTable + &H30, pOldDesc
    VBDll.GetMem2 ByVal pOldObjTable + &H2A, lModulesCount
   
    lSizeOfHeaders = lSizeOfHeaders + &H30 * lModulesCount
   
    ' // Free API external block
    VBDll.GetMem4 ByVal pOldProjInfo + &H238, lExtCount
    VBDll.GetMem4 ByVal pOldProjInfo + &H234, pOldExtApi
   
    For lIndex = 0 To lExtCount - 1
       
        VBDll.GetMem4 ByVal pOldExtApi + lIndex * 8, lExtFlags
       
        If lExtFlags <> 7 Then
            lNewExtCount = lNewExtCount + 1
        End If
       
    Next
   
    lSizeOfHeaders = lSizeOfHeaders + lNewExtCount * 8
               
    ' // Allocate memory for header
    pHeader = VBDll.HeapAlloc(VBDll.GetProcessHeap(), HEAP_ZERO_MEMORY, lSizeOfHeaders)
    If pHeader = 0 Then GoTo CleanUp

    lDifference = pHeader - mpVbHeader
   
    VBDll.CopyMemory ByVal pHeader, ByVal mpVbHeader, &H6A
   
    ' // Update strings offsets
    VBDll.CopyMemory tNames.pNames(0), ByVal mpVbHeader + &H58, &H10
   
    For lIndex = 0 To 3
        tNames.pNames(lIndex) = tNames.pNames(lIndex) - lDifference
    Next
       
    VBDll.CopyMemory ByVal pHeader + &H58, tNames.pNames(0), &H10

    ' // In order to keep global variables
    ' // Change the VbPublicObjectDescriptor.lpPublicBytes, VbPublicObjectDescriptor.lpStaticBytes
    pProjInfo = pHeader + &H6A

    VBDll.CopyMemory ByVal pProjInfo, ByVal pOldProjInfo, &H23C

    ' // Update on VBHeader
    VBDll.GetMem4 pProjInfo, ByVal pHeader + &H30

    ' // Create copy of Object table
    pObjTable = pProjInfo + &H23C

    VBDll.CopyMemory ByVal pObjTable, ByVal pOldObjTable, &H54

    ' // Update
    VBDll.GetMem4 pObjTable, ByVal pProjInfo + &H4

    ' // Allocate descriptors
    pDescriptors = pObjTable + &H54

    VBDll.CopyMemory ByVal pDescriptors, ByVal pOldDesc, lModulesCount * &H30

    ' // Update
    VBDll.GetMem4 pDescriptors, ByVal pObjTable + &H30

    ' // Allocate variables block
    pVarBlock = pDescriptors + lModulesCount * &H30

    For lIndex = 0 To lModulesCount - 1

        ' // Zero number of public and local variables
        VBDll.GetMem4 pVarBlock, ByVal pDescriptors + lIndex * &H30 + &H8
        VBDll.GetMem4 0&, ByVal pDescriptors + lIndex * &H30 + &HC

    Next
   
    ' // Free API
    pExtApi = pVarBlock + &HC
    lSubIndex = 0
   
    For lIndex = 0 To lExtCount - 1
       
        VBDll.GetMem4 ByVal pOldExtApi + lIndex * 8, lExtFlags
       
        If lExtFlags <> 7 Then
           
            VBDll.GetMem8 ByVal pOldExtApi + lIndex * 8, ByVal pExtApi + lSubIndex * 8
            lSubIndex = lSubIndex + 1
           
        End If
       
    Next
   
    ' // Update
    VBDll.GetMem4 pExtApi, ByVal pProjInfo + &H234
    VBDll.GetMem4 lNewExtCount, ByVal pProjInfo + &H238
   
    CreateVBHeaderCopy = pHeader
   
CleanUp:

End Function

---

Usage in C:

Code:

---

#include <windows.h>
#include <stdio.h>
#include <stdlib.h>
#include <time.h>
#include <initguid.h>

#include "interfaces.h"

volatile DWORD g_TlsSlot;

LONG __stdcall CallBack(IUnknown *pObj) {
        HRESULT hr;

        _Form *pForm;
        float fWidth, fHeight;

        if (FAILED(hr = pObj->lpVtbl->QueryInterface(pObj, &IID__Form, (void**)&pForm))) {
                return E_UNEXPECTED;
        }

        // Check if already initialized
        if (!TlsGetValue(g_TlsSlot)) {
                TlsSetValue(g_TlsSlot, (LPVOID)1);
                srand(time(NULL));
        }

        if (SUCCEEDED(hr = pForm->lpVtbl->get_ScaleWidth(pForm, &fWidth)) &&
                SUCCEEDED(hr = pForm->lpVtbl->get_ScaleHeight(pForm, &fHeight))) {
                hr = pForm->lpVtbl->Circle(pForm, 0, rand() % (int)fWidth, rand() % (int)fHeight, rand() % 500, 0, 0, 0, 0);
        }

        pForm->lpVtbl->Release(pForm);

        return hr;

}

int main(int argc, char **argv) {
        HINSTANCE hLib = LoadLibrary("CallbackThread.dll");
        DWORD g_TlsSlot = TlsAlloc();

        VOID (__stdcall *SetCallback)(LONG (__stdcall *)(IUnknown *)) =
                (VOID (__stdcall *)(LONG (__stdcall *)(IUnknown *)))GetProcAddress(hLib, "SetCallback");

        if (!SetCallback)
                return 1;

        SetCallback(CallBack);

        printf("press a button to exit\r\n");
        getchar();

        FreeLibrary(hLib);
        TlsFree(g_TlsSlot);

        return 0;

}

---

---

Hello Trick,

The e_lfanew is last field of IMAGE_DOS_HEADER structure.


How is the offset of &H3C calculated in the SearchForVbHeader in modDllInitialize module in the following code:

Code:

---

' // Get e_lfanew
    VBDll.GetMem4 ByVal hInstance + &H3C, ptr

---

In a similar way how is &H80 calculated in the following code.

Code:

---

  ' // Get IAT
    VBDll.GetMem4 ByVal ptr + &H80 + hInstance, pImportDesc

---

Thanks

Quote:

---

Originally Posted by The trick

You can't use an arbitrary code if you don't initialize the DLL-project-context, particularly the API calls declared in VB6.
The proper way is to call DLLGetClassObject and then to call the exported functions when you use the ActiveX Dll project type.
I had the thoughts to make the module which add the ability to initialize a context in DLL created as Standard EXE but there are some pitfalls like when you receive DLL_PROCESS_DETACH how you uninitialize the projects-context created in the other threads.

The attached archive contains the module and several examples of usage in 3 different languages (VB6, C, PureBasic):

• Simple - just show message box in DLL;
• ShowForm - show the Form from DLL;
• CallbackThread - create a thread in DLL and then call the callback function in EXE.

Because of the code module is quite raw one i don't publish it in the CodeBank:

Code:

---

' //
' // modDllInitialize.bas - The module provides support for runtime-initization for dynamic link libraries
' // Version 2
' // © Krivous Anatoly Anatolevich (The trick), 2015-2020
' // If you want to use additional callback from DllMain use DLL_USE_DLLMAIN conditional compilation adrgument
' // with the DllEntry callback function
' //

Option Explicit

Private Const PAGE_EXECUTE_READWRITE    As Long = &H40&
Private Const FADF_AUTO                As Long = 1
Private Const VB_MAGIC                  As Long = &H21354256
Private Const HEAP_ZERO_MEMORY          As Long = &H8
Private Const HEAP_NO_SERIALIZE        As Long = &H1
Private Const TLS_OUT_OF_INDEXES        As Long = &HFFFF&

' // Lazy GUID structure
Private Type tCurGUID
    c1          As Currency
    c2          As Currency
End Type

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 tVBHeaderString
    pNames(3)  As Long
End Type

Private Const DLL_PROCESS_ATTACH    As Long = 1
Private Const DLL_PROCESS_DETACH    As Long = 0
Private Const DLL_THREAD_ATTACH    As Long = 2
Private Const DLL_THREAD_DETACH    As Long = 3

Private mlTlsSlot  As Long    ' // Index of the item in the TLS. There will be data specific to the thread.
Private mpVbHeader  As Long    ' // Pointer to VBHeader structure.
Private mhInstance  As Long    ' // Base address of the module

' // Unused
Private Sub Main()

End Sub

' // This function is called when the module is being loaded/unloaded to a process or a thread is created/destroyed
Public Function DllMain( _
                ByVal hinstDLL As Long, _
                ByVal fdwReason As Long, _
                ByVal lpvReserved As Long) As Long

    Select Case fdwReason
    Case DLL_PROCESS_ATTACH
       
        If VBDll.UserDllMain(mhInstance, 0, hinstDLL, fdwReason, lpvReserved) = 0 Then
            GoTo CleanUp
        End If

        mlTlsSlot = VBDll.TlsAlloc()
        If mlTlsSlot = TLS_OUT_OF_INDEXES Then GoTo CleanUp
       
        DllMain = InitializeRuntimeForProject(hinstDLL, True) And 1
       
#If DLL_USE_DLLMAIN Then
        If DllMain Then
            DllMain = DllEntry(hinstDLL, fdwReason, lpvReserved)
        End If
#End If

    Case DLL_THREAD_ATTACH

        If VBDll.UserDllMain(mhInstance, 0, hinstDLL, fdwReason, lpvReserved) = 0 Then
            GoTo CleanUp
        End If

        DllMain = InitializeRuntimeForProject(hinstDLL, False) And 1

#If DLL_USE_DLLMAIN Then
        If DllMain Then
            DllMain = DllEntry(hinstDLL, fdwReason, lpvReserved)
        End If
#End If

    Case DLL_THREAD_DETACH

#If DLL_USE_DLLMAIN Then
        DllEntry hinstDLL, fdwReason, lpvReserved
#End If

        If VBDll.UserDllMain(mhInstance, 0, hinstDLL, fdwReason, lpvReserved) = 0 Then
            GoTo CleanUp
        End If

        UninitializeRuntimeForProject hinstDLL
       
        FreeHeaderForCurrentThread
       
        DllMain = 1

    Case DLL_PROCESS_DETACH

#If DLL_USE_DLLMAIN Then
        DllEntry hinstDLL, fdwReason, lpvReserved
#End If
       
        CanUnloadNowCall

        VBDll.UserDllMain mhInstance, 0, hinstDLL, fdwReason, lpvReserved
       
        FreeHeaderForCurrentThread
       
        VBDll.TlsFree mlTlsSlot

        mlTlsSlot = 0
        mpVbHeader = 0
       
        DllMain = 1
       
        Exit Function
       
    End Select
     
CleanUp:

End Function

' // Uninitialize the runime
Public Function UninitializeRuntimeForProject( _
                ByVal hInstance As Long) As Boolean
    Dim pNewHeader  As Long
   
    ' // Check if the module is initialized
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
    If pNewHeader = 0 Then Exit Function

    VBDll.CoUninitialize
   
    UninitializeRuntimeForProject = True
   
End Function

' // Free the current header
Public Function FreeHeaderForCurrentThread() As Boolean
    Dim pNewHeader  As Long
   
    ' // Check if the module is initialized
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
    If pNewHeader = 0 Then Exit Function
   
    VBDll.HeapFree VBDll.GetProcessHeap(), 0, pNewHeader
   
End Function

' // Initilaize the runtime
Public Function InitializeRuntimeForProject( _
                ByVal hInstance As Long, _
                ByVal bIsFirst As Boolean) As Boolean
    Dim pNewHeader  As Long
    Dim tClsId      As tCurGUID
    Dim tIID        As tCurGUID
    Dim lUnused    As Long
   
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
   
    ' // Check if the module already initialized
    If pNewHeader Then

        InitializeRuntimeForProject = True
        Exit Function
       
    End If
   
    VBDll.CoInitialize ByVal 0&
   
    If mpVbHeader = 0 Then
       
        ' // Search for VBHeader (EXEPROJECTINFO)
        mpVbHeader = SearchForVbHeader(hInstance)
        If mpVbHeader = 0 Then Exit Function
       
        ' // Modify header
        ModifyVBHeader
       
    End If
   
    ' // Create the new copy of headers for new instance
    pNewHeader = CreateVBHeaderCopy()
   
    ' // Save it
    VBDll.TlsSetValue mlTlsSlot, ByVal pNewHeader

    If pNewHeader = 0 Then
        Exit Function
    End If
   
    ' // IID_IUnknown
    tIID.c2 = 504403158265495.5712@
   
    ' // Call CThreadPool::InitDllAccess
    VBDll.VBDllGetClassObject hInstance, 0, pNewHeader, tClsId, tIID, 0
   
    If bIsFirst Then
        ' // Initialize App object
        lUnused = App.ThreadID
    End If
   
    InitializeRuntimeForProject = True
   
End Function

Private Sub CanUnloadNowCall()
    Dim pNewHeader  As Long
    Dim bThreading  As Byte
   
    ' // Check if the module is initialized
    pNewHeader = VBDll.TlsGetValue(mlTlsSlot)
    If pNewHeader = 0 Then Exit Sub

    ' // To ensure cleaning of the project data set the threading model to the apartment one.
    VBDll.GetMem1 ByVal pNewHeader + &H3C, bThreading
    bThreading = bThreading Or 1
    VBDll.GetMem1 bThreading, ByVal pNewHeader + &H3C
   
    ' // The runtime will call CThreadPool::CheckForProjectUnload and CVBThreadAction::CleanupProjData
    If VBDll.VBDllCanUnloadNow(pNewHeader) Then
        Exit Sub
    End If

End Sub

' // Search for VBHeader(EXEPROJECTINFO)
Private Function SearchForVbHeader( _
                ByVal hInstance As Long) As Long
    Dim ptr            As Long
    Dim lSignature      As Long
    Dim pImportDesc    As Long
    Dim pStartSearch    As Long
    Dim pEndSearch      As Long
    Dim bData()        As Byte
    Dim tArrDesc        As SAFEARRAY
    Dim lIndex          As Long
   
    ' // VBHeader is placed within the end of IAT and beginning of IMAGE_IMPORT_DESCRIPTOR
   
    ' // Get e_lfanew
    VBDll.GetMem4 ByVal hInstance + &H3C, ptr
    ' // Get IAT
    VBDll.GetMem4 ByVal ptr + &H80 + hInstance, pImportDesc
   
    pEndSearch = hInstance + pImportDesc - 4
   
    Do
   
        ' // Get IMAGE_IMPORT_DESCRIPTOR.FirstThunk
        VBDll.GetMem4 ByVal pImportDesc + &H10 + hInstance, ptr
       
        If ptr > pStartSearch Then
            pStartSearch = ptr
        End If
       
        pImportDesc = pImportDesc + &H14
       
    Loop While ptr
   
    ' // Search for null-thunk (skip valid IAT entries)
    Do
       
        VBDll.GetMem4 ByVal hInstance + pStartSearch, ptr
        pStartSearch = pStartSearch + 4
       
    Loop While ptr
   
    pStartSearch = pStartSearch + hInstance
   
    If pEndSearch < pStartSearch Then Exit Function
   
    ' // Map the array to the data
    tArrDesc.cbElements = 1
    tArrDesc.cDims = 1
    tArrDesc.fFeatures = FADF_AUTO
    tArrDesc.pvData = pStartSearch
    tArrDesc.Bounds.cElements = pEndSearch - pStartSearch + 5
   
    VBDll.MoveArray bData(), VarPtr(tArrDesc)
   
    For lIndex = 0 To tArrDesc.Bounds.cElements - 5
       
        ' // __vbaS of an exe module has the following structure:
        ' // PUSH OFFSET VbHeader
        ' // CALL ThunRTMain
       
        ' // Search for PUSH IMM opcode
        If bData(lIndex) = &H68 Then
           
            ' // Get Immediate value
            VBDll.GetMem4 bData(lIndex + 1), ptr
           
            ' // Check range
            If ptr >= pStartSearch And ptr < pEndSearch Then
               
                ' // Check signature (VB5!)
                VBDll.GetMem4 ByVal ptr, lSignature
               
                If lSignature = VB_MAGIC Then
                   
                    SearchForVbHeader = ptr
                    Exit Function
                   
                End If
               
            End If
           
        End If
       
    Next
   
End Function

' // Modify VBHeader to replace Sub Main
Private Sub ModifyVBHeader()
    Dim ptr            As Long
    Dim lOldProtect    As Long
    Dim lFlags          As Long
    Dim lFormsCount    As Long
    Dim lModulesCount  As Long
    Dim lStructSize    As Long
   
    ' // Allow to write to that page
    VBDll.VirtualProtect ByVal mpVbHeader, &H64, PAGE_EXECUTE_READWRITE, lOldProtect
   
    ' // Remove Sub Main
    ptr = mpVbHeader + &H2C
    VBDll.GetMem4 0&, ByVal ptr

    VBDll.VirtualProtect ByVal mpVbHeader, &H64, lOldProtect, 0
   
    ' // Remove startup form
    VBDll.GetMem4 ByVal mpVbHeader + &H4C, ptr
    ' // Get number of forms
    VBDll.GetMem2 ByVal mpVbHeader + &H44, lFormsCount
   
    Do While lFormsCount > 0
   
        ' // Get structure size
        VBDll.GetMem4 ByVal ptr, lStructSize
       
        ' // Get flag (unknown5) from current form
        VBDll.GetMem4 ByVal ptr + &H28, lFlags
       
        ' // When set, bit 5,
        If lFlags And &H10 Then
       
            ' // Unset bit 5
            lFlags = lFlags And &HFFFFFFEF
            ' // Are allowed to write in the page
            VBDll.VirtualProtect ByVal ptr, 4, PAGE_EXECUTE_READWRITE, lOldProtect
            ' // Write changet lFlags
            VBDll.GetMem4 lFlags, ByVal ptr + &H28
            ' // Restoring the memory attributes
            VBDll.VirtualProtect ByVal ptr, 4, lOldProtect, 0
           
        End If
       
        lFormsCount = lFormsCount - 1
        ptr = ptr + lStructSize
       
    Loop

End Sub

' // Create copy of VBHeader and other structures
Private Function CreateVBHeaderCopy() As Long
    Dim pHeader        As Long
    Dim pOldProjInfo    As Long
    Dim pProjInfo      As Long
    Dim pObjTable      As Long
    Dim pOldObjTable    As Long
    Dim lDifference    As Long
    Dim lIndex          As Long
    Dim lSubIndex      As Long
    Dim tNames          As tVBHeaderString
    Dim lModulesCount  As Long
    Dim pDescriptors    As Long
    Dim pOldDesc        As Long
    Dim pVarBlock      As Long
    Dim lSizeOfHeaders  As Long
    Dim lExtCount      As Long
    Dim lNewExtCount    As Long
    Dim pOldExtApi      As Long
    Dim pExtApi        As Long
    Dim lExtFlags      As Long

    ' // Get size of all headers
    lSizeOfHeaders = &H6A + &H23C + &H54 + &HC
   
    VBDll.GetMem4 ByVal mpVbHeader + &H30, pOldProjInfo
    VBDll.GetMem4 ByVal pOldProjInfo + &H4, pOldObjTable
    VBDll.GetMem4 ByVal pOldObjTable + &H30, pOldDesc
    VBDll.GetMem2 ByVal pOldObjTable + &H2A, lModulesCount
   
    lSizeOfHeaders = lSizeOfHeaders + &H30 * lModulesCount
   
    ' // Free API external block
    VBDll.GetMem4 ByVal pOldProjInfo + &H238, lExtCount
    VBDll.GetMem4 ByVal pOldProjInfo + &H234, pOldExtApi
   
    For lIndex = 0 To lExtCount - 1
       
        VBDll.GetMem4 ByVal pOldExtApi + lIndex * 8, lExtFlags
       
        If lExtFlags <> 7 Then
            lNewExtCount = lNewExtCount + 1
        End If
       
    Next
   
    lSizeOfHeaders = lSizeOfHeaders + lNewExtCount * 8
               
    ' // Allocate memory for header
    pHeader = VBDll.HeapAlloc(VBDll.GetProcessHeap(), HEAP_ZERO_MEMORY, lSizeOfHeaders)
    If pHeader = 0 Then GoTo CleanUp

    lDifference = pHeader - mpVbHeader
   
    VBDll.CopyMemory ByVal pHeader, ByVal mpVbHeader, &H6A
   
    ' // Update strings offsets
    VBDll.CopyMemory tNames.pNames(0), ByVal mpVbHeader + &H58, &H10
   
    For lIndex = 0 To 3
        tNames.pNames(lIndex) = tNames.pNames(lIndex) - lDifference
    Next
       
    VBDll.CopyMemory ByVal pHeader + &H58, tNames.pNames(0), &H10

    ' // In order to keep global variables
    ' // Change the VbPublicObjectDescriptor.lpPublicBytes, VbPublicObjectDescriptor.lpStaticBytes
    pProjInfo = pHeader + &H6A

    VBDll.CopyMemory ByVal pProjInfo, ByVal pOldProjInfo, &H23C

    ' // Update on VBHeader
    VBDll.GetMem4 pProjInfo, ByVal pHeader + &H30

    ' // Create copy of Object table
    pObjTable = pProjInfo + &H23C

    VBDll.CopyMemory ByVal pObjTable, ByVal pOldObjTable, &H54

    ' // Update
    VBDll.GetMem4 pObjTable, ByVal pProjInfo + &H4

    ' // Allocate descriptors
    pDescriptors = pObjTable + &H54

    VBDll.CopyMemory ByVal pDescriptors, ByVal pOldDesc, lModulesCount * &H30

    ' // Update
    VBDll.GetMem4 pDescriptors, ByVal pObjTable + &H30

    ' // Allocate variables block
    pVarBlock = pDescriptors + lModulesCount * &H30

    For lIndex = 0 To lModulesCount - 1

        ' // Zero number of public and local variables
        VBDll.GetMem4 pVarBlock, ByVal pDescriptors + lIndex * &H30 + &H8
        VBDll.GetMem4 0&, ByVal pDescriptors + lIndex * &H30 + &HC

    Next
   
    ' // Free API
    pExtApi = pVarBlock + &HC
    lSubIndex = 0
   
    For lIndex = 0 To lExtCount - 1
       
        VBDll.GetMem4 ByVal pOldExtApi + lIndex * 8, lExtFlags
       
        If lExtFlags <> 7 Then
           
            VBDll.GetMem8 ByVal pOldExtApi + lIndex * 8, ByVal pExtApi + lSubIndex * 8
            lSubIndex = lSubIndex + 1
           
        End If
       
    Next
   
    ' // Update
    VBDll.GetMem4 pExtApi, ByVal pProjInfo + &H234
    VBDll.GetMem4 lNewExtCount, ByVal pProjInfo + &H238
   
    CreateVBHeaderCopy = pHeader
   
CleanUp:

End Function

---

Usage in C:

Code:

---

#include <windows.h>
#include <stdio.h>
#include <stdlib.h>
#include <time.h>
#include <initguid.h>

#include "interfaces.h"

volatile DWORD g_TlsSlot;

LONG __stdcall CallBack(IUnknown *pObj) {
        HRESULT hr;

        _Form *pForm;
        float fWidth, fHeight;

        if (FAILED(hr = pObj->lpVtbl->QueryInterface(pObj, &IID__Form, (void**)&pForm))) {
                return E_UNEXPECTED;
        }

        // Check if already initialized
        if (!TlsGetValue(g_TlsSlot)) {
                TlsSetValue(g_TlsSlot, (LPVOID)1);
                srand(time(NULL));
        }

        if (SUCCEEDED(hr = pForm->lpVtbl->get_ScaleWidth(pForm, &fWidth)) &&
                SUCCEEDED(hr = pForm->lpVtbl->get_ScaleHeight(pForm, &fHeight))) {
                hr = pForm->lpVtbl->Circle(pForm, 0, rand() % (int)fWidth, rand() % (int)fHeight, rand() % 500, 0, 0, 0, 0);
        }

        pForm->lpVtbl->Release(pForm);

        return hr;

}

int main(int argc, char **argv) {
        HINSTANCE hLib = LoadLibrary("CallbackThread.dll");
        DWORD g_TlsSlot = TlsAlloc();

        VOID (__stdcall *SetCallback)(LONG (__stdcall *)(IUnknown *)) =
                (VOID (__stdcall *)(LONG (__stdcall *)(IUnknown *)))GetProcAddress(hLib, "SetCallback");

        if (!SetCallback)
                return 1;

        SetCallback(CallBack);

        printf("press a button to exit\r\n");
        getchar();

        FreeLibrary(hLib);
        TlsFree(g_TlsSlot);

        return 0;

}

---

---

Hello Trick,

How to call a third party vb6 standard dll exported function using Declare statement
or LoadLibrary/GetProcAddress in a vb6 standard exe.Here I cannot make the following code from modDllInitialize.bas of DllMain() run automatically in this third party dll since the dll is third party dll (ie., .dll without source code).

Code:

---

Case DLL_PROCESS_ATTACH
       
        If VBDll.UserDllMain(mhInstance, 0, hinstDLL, fdwReason, lpvReserved) = 0 Then
            GoTo CleanUp
        End If

        mlTlsSlot = VBDll.TlsAlloc()
        If mlTlsSlot = TLS_OUT_OF_INDEXES Then GoTo CleanUp
       
        DllMain = InitializeRuntimeForProject(hinstDLL, True) And 1

---

Thanks

Quote:

---

Originally Posted by smkperu

Hello Trick,

How to call a third party vb6 standard dll exported function using Declare statement
or LoadLibrary/GetProcAddress in a vb6 standard exe.Here I cannot make the following code from modDllInitialize.bas of DllMain() run automatically in this third party dll since the dll is third party dll (ie., .dll without source code).

Code:

---

Case DLL_PROCESS_ATTACH
       
        If VBDll.UserDllMain(mhInstance, 0, hinstDLL, fdwReason, lpvReserved) = 0 Then
            GoTo CleanUp
        End If

        mlTlsSlot = VBDll.TlsAlloc()
        If mlTlsSlot = TLS_OUT_OF_INDEXES Then GoTo CleanUp
       
        DllMain = InitializeRuntimeForProject(hinstDLL, True) And 1

---

Thanks

---

Dear smkperu,

The following is the code which you have to use to call any exported function of your 3rd party standard dll without restrictions in your vb6 standard exe.

Code:

---

Dim tClsId      As tCurGUID
Dim tIID        As tCurGUID
Dim  dllhinstance  As long
Dim vbhdr as long

    dllhinstance = LoadLibrary("full path of third party dll")
       
    vbhdr = SearchForVbHeader(dllhinstance) 'getvbheader
 
    'get IID_IUnknown
    tIID.c2 = 504403158265495.5712@
   
    ' init runtime
    VBDll.VBDllGetClassObject dllhinstance , 0, vbhdr , tClsId, tIID, 0

    'call any exported function of the third party dll which  you have already declared using Declare statement.

---

regards,

JSVenu

Quote:

---

Originally Posted by jsvenu

Dear smkperu,

The following is the code which you have to use to call any exported function of your 3rd party standard dll without restrictions in your vb6 standard exe.

Code:

---

Dim tClsId      As tCurGUID
Dim tIID        As tCurGUID
Dim  dllhinstance  As long
Dim vbhdr as long

    dllhinstance = LoadLibrary("full path of third party dll")
       
    vbhdr = SearchForVbHeader(dllhinstance) 'getvbheader
 
    'get IID_IUnknown
    tIID.c2 = 504403158265495.5712@
   
    ' init runtime
    VBDll.VBDllGetClassObject dllhinstance , 0, vbhdr , tClsId, tIID, 0

    'call any exported function of the third party dll which  you have already declared using Declare statement.

---

regards,

JSVenu

---

Hello JSVenu,

Thanks for the working code.

Thanks