Mensajes

Podrias resubir el archivo?, gracias y disculpas por revivirlo 

Hola la verdad no entiendo el codigo y me cierra todo con error cuando llamo a InitCurrentThread

como aplicas eso con las apis de inet?

Llama la función CreateNewThread pasandole el puntero a una funcion donde se iniciará el nuevo hilo, al inicio de esa funcion llama InitCurrentThread y luego hace las llamadas que quieras, todo eso será en un nuevo thread, recorda usar vbModal cuando vas a mostrar forms y lo que dije anteriormente pon Sub Main como objeto inicial y desde ahi inicia el/los forms normalmente

Saludos

Lo hice hace ya un tiempo para hacer poner imágenes en los commandbutton y que queden en la misma linea, pero se puede aplicar a cualquier control.

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Const WM_PAINT As Long = &HF
Private Const GWL_WNDPROC = -4

Private Type DRAW_DATA
    DrawPic As PictureBox
    DrawTop As Long
    DrawLeft As Long
    lpPrevWndProc As Long
    ControlHwnd As Long
    ControlDC As Long
End Type

Private Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "USER32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal Hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetDC Lib "USER32" (ByVal Hwnd As Long) As Long
Private Declare Function GdiTransparentBlt Lib "GDI32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean

Private DrawArray() As DRAW_DATA

Public Sub DrawGraph(Hwnd As Long, Pic As PictureBox, Top As Long, Left As Long)
    Dim i As Long
   
    If Not Not DrawArray Then: i = UBound(DrawArray) + 1
    ReDim Preserve DrawArray(i)
   
    With DrawArray(i)
        Set .DrawPic = Pic
        .DrawPic.BorderStyle = 0
        .DrawPic.ScaleMode = vbPixels
        .DrawPic.BackColor = &HFF00FF
        .DrawPic.AutoSize = True
        .DrawPic.Refresh
   
        .ControlHwnd = Hwnd
        .lpPrevWndProc = SetWindowLong(Hwnd, GWL_WNDPROC, AddressOf ControlProc)
        .ControlDC = GetDC(Hwnd)
        .DrawTop = Top: .DrawLeft = Left
    End With
End Sub

Public Sub UnDrawGraph(ByVal Hwnd As Long)
    Dim i As Long
   
    For i = 0 To UBound(DrawArray)
        If DrawArray(i).ControlHwnd = Hwnd Then
            Call SetWindowLong(Hwnd, GWL_WNDPROC, DrawArray(i).lpPrevWndProc)
        End If
    Next i
End Sub

Private Function ControlProc(ByVal Hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim i As Long

    For i = 0 To UBound(DrawArray)
        With DrawArray(i)
            If .ControlHwnd = Hwnd Then
                ControlProc = CallWindowProc(.lpPrevWndProc, Hwnd, Msg, wParam, lParam)
                If (Msg = WM_PAINT) Then
                    Call GdiTransparentBlt(.ControlDC, .DrawLeft, .DrawTop, .DrawPic.ScaleWidth, .DrawPic.ScaleHeight, .DrawPic.hdc, 0, 0, .DrawPic.ScaleWidth, .DrawPic.ScaleHeight, &HFF00FF)
                End If
            End If
        End With
    Next i
End Function

[mProgressBarInListView:]

mProgressBarInListView:

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Type RECT
    Left    As Long
    Top     As Long
    Right   As Long
    Bottom  As Long
End Type

Private Const LVM_FIRST As Long = &H1000
Private Const LVM_GETSUBITEMRECT  As Long = (LVM_FIRST + 56)
Private Const LVIR_LABEL  As Long = 2

Private Const WM_NOTIFY  As Long = &H4E
Private Const WM_HSCROLL As Long = &H114
Private Const WM_VSCROLL As Long = &H115
Private Const WM_KEYDOWN As Long = &H100

Private Const HDN_FIRST      As Long = (0 - 300)
Private Const HDN_ENDTRACK   As Long = (HDN_FIRST - 1)

Private Declare Function SendMessageA Lib "USER32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetParent Lib "USER32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Declare Function SetWindowLongA Lib "USER32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProcA Lib "USER32" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private lpPrevWndProc As Long

Private Function ListView_GetSubItemRect(ByVal hWndLV As Long, ByVal iItem As Long, ByVal iSubItem As Long, ByVal code As Long, lpRect As RECT) As Boolean
    lpRect.Top = iSubItem
    lpRect.Left = code
    ListView_GetSubItemRect = SendMessageA(hWndLV, LVM_GETSUBITEMRECT, ByVal iItem, lpRect)
End Function

Public Sub PutProgressBarInListView(ListView As ListView, InColumn As Long)
    Dim i As Long
   
    For i = 0 To ListView.ListItems.Count - 1
        If i > Form1.ProgressBar1.Count - 1 Then: Call Load(Form1.ProgressBar1(i))
        Call SetParent(Form1.ProgressBar1(i).hWnd, ListView.hWnd)
    Next

    Call AdjustProgressBar(ListView, InColumn)
    lpPrevWndProc = SetWindowLongA(ListView.hWnd, -4, AddressOf ListViewProc)
End Sub

Public Sub AdjustProgressBar(ListView As ListView, InColumn As Long)
    Dim Pos    As RECT
    Dim i      As Long
   
    For i = 0 To Form1.ProgressBar1.Count - 1
        Call ListView_GetSubItemRect(ListView.hWnd, i, InColumn, LVIR_LABEL, Pos)
        With Form1.ProgressBar1(i)
            .Left = (Pos.Left) * Screen.TwipsPerPixelX
            .Width = (Pos.Right - Pos.Left) * Screen.TwipsPerPixelX
            .Height = ((Pos.Bottom - Pos.Top) * Screen.TwipsPerPixelY)
            .Top = Pos.Top * Screen.TwipsPerPixelY + ((Pos.Bottom - Pos.Top) * Screen.TwipsPerPixelY - .Height) / 2
           
            Call IIf(Pos.Top <= 3, .Visible = False, .Visible = True)
        End With
    Next
End Sub

Private Function ListViewProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim Param       As Long
    Dim bAdjust     As Boolean

    Select Case Msg
        Case WM_HSCROLL, WM_VSCROLL: bAdjust = True
        Case WM_KEYDOWN
            Select Case wParam
                Case 33 To 40: bAdjust = True
            End Select
        Case WM_NOTIFY
            Call CopyMemory(Param, ByVal lParam + 8, 4)
            If Param = HDN_ENDTRACK Then: bAdjust = True
    End Select
   
    If bAdjust = True Then: Call AdjustProgressBar(Form1.ListView1, 1)
    ListViewProc = CallWindowProcA(lpPrevWndProc, hWnd, Msg, wParam, lParam)
End Function

Simplemente necesitaba hacer esto y lo comparto, espero que le sirva a alguien

@F3B14N  si seria lo correcto, pero la verdad no le tengo mucha fe a vb con el uso de threads  seria un gran dolor de cabeza.

Código (vb) [Seleccionar] Expandir

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Declare Function VirtualProtect Lib "KERNEL32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function CreateThread Lib "KERNEL32" (ByVal lpSecurityAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Private Declare Function ReadProcessMemory Lib "KERNEL32" (ByVal hProcess As Long, ByRef lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
Private Declare Function VBDllGetClassObject Lib "MSVBVM60" (g1 As Long, g2 As Long, ByVal g3_vbHeader As Long, REFCLSID As Long, REFIID As GUID, ppv As Long) As Long
Private Declare Function CreateIExprSrvObj Lib "MSVBVM60" (ByVal p1_0 As Long, ByVal p2_4 As Long, ByVal p3_0 As Long) As Long
Private Declare Function CoInitialize Lib "OLE32" (ByVal pvReserved As Long) As Long
Private Declare Sub CoUninitialize Lib "OLE32" ()
Private VBHeaderAddress As Long
Private MainAddress As Long

Public Sub CreateNewThread(ByVal lAddress As Long, ByVal lVal As Long, Optional ByRef lHandle As Long, Optional ByRef lThread As Long)
    If VBHeaderAddress = 0 Then
        Call GetFakeHeader: Call GetMainAddress
        Call VirtualProtect(ByVal MainAddress, 1, &H40, 0&)
    End If
    lHandle = CreateThread(ByVal 0&, ByVal 0&, lAddress, ByVal lVal, 0, lThread)
End Sub

Public Sub InitCurrentThread()
    Call CreateIExprSrvObj(0, 4, 0)
    Call CoInitialize(0)
    Call InitDLL
End Sub

Public Sub TerminateCurrentThread()
    Call CoUninitialize
End Sub

Public Sub GetFakeHeader()
    Dim lPtr            As Long
    Dim lProc           As Long
    Dim bData(1024)     As Byte
    Dim sData           As String
    Dim lRet            As Long
       
    lPtr = App.hInstance
    Do While lRet = 0
        Call ReadProcessMemory(-1, ByVal lPtr, bData(0), 1024, 0&)
        sData = StrConv(bData, vbUnicode)
        lRet = InStr(1, sData, "VB5!", vbBinaryCompare)
        lPtr = lPtr + 1024
    Loop
    VBHeaderAddress = lPtr + lRet - 1024 - 1
End Sub

Private Sub GetMainAddress()
    Call ReadProcessMemory(-1, ByVal VBHeaderAddress + &H2C, MainAddress, 4, 0&)
    'If MainAddress = 0 Then
    '    'MainAddress = AddressOf Private Sub Form_Initialize()
    'End If
End Sub

Private Sub InitDLL()
    Dim pIID As GUID

    With pIID
        .Data1 = 1
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
   
    Call ReadProcessMemory(-1, &HC3, ByVal MainAddress, 4, 0&)
    Call VBDllGetClassObject(0, 0, VBHeaderAddress, 0, pIID, 0)
    Call ReadProcessMemory(-1, &H8B, ByVal MainAddress, 4, 0&)
End Sub

Private Sub Main()
    CLIENT_Main.Show
End Sub

Funciona sin problemas, simplemente pon Sub Main como objeto inicial y desde ahi inicia el/los forms normalmente. Recorda llamar InitCurrentThread en cada nuevo thread también.

Podrias usar las estructuras definidas en este script de IDA: http://www.openrce.org/downloads/details/245/VB_Helper_Script

Solo debes convertirlas para usarlas con VB y listo...

Saludos!

Gracias, pero aún sigo sin lograr lo que busco, seguiré intentandolo 
Aca dejo las estructuras y poco mas para quienes las puedan necesitar:

Código (vb) [Seleccionar] Expandir

Private Type VBHeader
    szVbMagic As Long '0x00, VB5! String
    wRuntimeBuild  As Integer '0x04, Build of the VB6 Runtime
    szLangDll(13) As Byte '0x06, Language Extension DLL
    szSecLangDll(13) As Byte '0x14, Language Extension DLL
    wRuntimeRevision As Integer '0x22, Internal Runtime Revision
    dwLcid  As Long '0x24, LCID of Language DLL
    dwSecLCID   As Long '0x28, LCID of 2nd Language DLL
    lpSubMain   As Long '0x2C, Pointer to Sub Main Code
    lpProjectData As Long '0x30, Pointer to Project Data
    fMdlIntCtls As Long '0x34, VB Control Flags for IDs < 32
    fMdlIntCtls2 As Long '0x38, VB Control Flags for IDs > 32
    dwThreadFlags As Long '0x3C, Threading Mode
    dwThreadCount As Long '0x40, Threads to support in pool
    wFormCount As Long '0x44, Number of forms present
    wExternalCount As Integer '0x46, Number of external controls
    dwThunkCount As Long '0x48, Number of thunks to create
    lpGuiTable As Long '0x4C, Pointer to GUI Table
    lpExternalTable As Long '0x50, Pointer to External Table
    lpComRegisterData As Long '0x54, Pointer to COM Information
    bSZProjectDescription As Long '0x58, Offset to Project Description
    bSZProjectExeName As Long '0x5C, Offset to Project EXE Name
    bSZProjectHelpFile As Long '0x60, Offset to Project Help File
    bSZProjectName As Long '0x64, Offset to Project Name
End Type
                                                     
Private Type COMRegistrationData
    bRegInfo As Long '0x00, Offset to COM Interfaces Info
    bSZProjectName As Long '0x04, Offset to Project/Typelib Name
    bSZHelpDirectory As Long '0x08, Offset to Help Directory
    bSZProjectDescription As Long '0x0C, Offset to Project Description
    uuidProjectClsId(15) As Byte ' 0x10, CLSID of Project/Typelib
    dwTlbLcid As Long '0x20, LCID of Type Library
    wUnknown As Integer '0x24, Might be something. Must check
    wTlbVerMajor As Integer '0x26, Typelib Major Version
End Type
                                                       
Private Type COMRegistrationInfo
    bNextObject     As Long '0x00, Offset to COM Interfaces Info
    bObjectName     As Long '0x04, Offset to Object Name
    bObjectDescription  As Long '0x08, Offset to Object Description
    dwInstancing    As Long '0x0C, Instancing Mode
    dwObjectId  As Long '0x10, Current Object ID in the Project
    uuidObject(15) As Byte  '0x14, CLSID of Object
    fIsInterface    As Long '0x24, Specifies if the next CLSID is valid
    bUuidObjectIFace    As Long '0x28, Offset to CLSID of Object Interface
    bUuidEventsIFace    As Long '0x2C, Offset to CLSID of Events Interface
    fHasEvents  As Long '0x30, Specifies if the CLSID above is valid
    dwMiscStatus    As Long '0x34, OLEMISC Flags (see MSDN docs)
    fClassType As Byte '0x38, Class Type
    fObjectType As Byte '0x39, Flag identifying the Object Type
    wToolboxBitmap32 As Integer '0x3A, Control Bitmap ID in Toolbox
    wDefaultIcon As Integer '0x3C, Minimized Icon of Control Window
    fIsDesigner As Integer ' 0x3E, Specifies whether this is a Designer
    bDesignerData As Long '0x40, Offset to Designer Data
End Type
                                                     
Private Type DesignerInfo
    uuidDesigner(15) As Byte '0x00, CLSID of the Addin/Designer
    cbStructSize As Long '0x10, Total Size of the next fields.
    '    ea = ea + 0x18;
    '    MakeDword       (ea - 0x04
    'bstrAddinRegKey     FixStr          (ea, Registry Key of the Addin
    '    ea = ea + 0x04 + Dword(ea - 0x04
    '    MakeDword       (ea - 0x04
    'bstrAddinName   FixStr          (ea, Friendly Name of the Addin
    '    ea = ea + 0x04 + Dword(ea - 0x04
    '    MakeDword       (ea - 0x04
    'bstrAddinDescription    FixStr          (ea, Description of Addin
    '    ea = ea + Dword(ea - 0x04
    'dwLoadBehaviour     FixDword        (ea, CLSID of Object
    '    ea = ea + 0x08;
    '    MakeDword       (ea - 0x04
    'bstrSatelliteDll    FixStr          (ea, Satellite DLL, if specified
    '    ea = ea + 0x04 + Dword(ea - 0x04
    '    MakeDword       (ea - 0x04
    'bstrAdditionalRegKey    FixStr          (ea, Extra Registry Key, if specified
    '    ea = ea + Dword(ea - 0x04
    'dwCommandLineSafe   FixDword        (ea, Specifies a GUI-less Addin if 1.
End Type
                                                     
Private Type ProjectInformation
    dwVersion   As Long '0x00, 5.00 in Hex (0x1F4). Version.
    lpObjectTable   As Long '0x04, Pointer to the Object Table
    dwNull  As Long '0x08, Unused value after compilation.
    lpCodeStart     As Long '0x0C, Points to start of code. Unused.
    lpCodeEnd   As Long '0x10, Points to end of code. Unused.
    dwDataSize  As Long '0x14, Size of VB Object Structures. Unused.
    lpThreadSpace   As Long '0x18, Pointer to Pointer to Thread Object.
    lpVbaSeh    As Long '0x1C, Pointer to VBA Exception Handler
    lpNativeCode    As Long '0x20, Pointer to .DATA section.
    szPathInformation(527) As Byte '0x24, Contains Path and ID string. < SP6
    lpExternalTable     As Long '0x234, Pointer to External Table.
    dwExternalCount     As Long '0x238, Objects in the External Table.
End Type

Private Type SecondaryProjectInformation
    lpHeapLink  As Long '0x00, Unused after compilation, always 0.
    lpObjectTable   As Long '0x04, Back-Pointer to the Object Table.
    dwReserved  As Long '0x08, Always set to -1 after compiling. Unused
    dwUnused    As Long '0x0C, Not written or read in any case.
    lpObjectList    As Long '0x10, Pointer to Object Descriptor Pointers.
    dwUnused2   As Long '0x14, Not written or read in any case.
    szProjectDescription    As Long '0x18, Pointer to Project Description
    szProjectHelpFile   As Long '0x1C, Pointer to Project Help File
    dwReserved2     As Long '0x20, Always set to -1 after compiling. Unused
    dwHelpContextId     As Long '0x24, Help Context ID set in Project Settings.
End Type
           
Private Type ObjectTable
    lpHeapLink  As Long '0x00, Unused after compilation, always 0.
    lpExecProj  As Long '0x04, Pointer to VB Project Exec COM Object.
    lpProjectInfo2  As Long '0x08, Secondary Project Information.
    dwReserved  As Long '0x0C, Always set to -1 after compiling. Unused
    dwNull  As Long '0x10, Not used in compiled mode.
    lpProjectObject     As Long '0x14, Pointer to in-memory Project Data.
    uuidObject(15) As Byte '0x18, GUID of the Object Table.
    fCompileState   As Integer '0x28, Internal flag used during compilation.
    dwTotalObjects  As Integer '0x2A, Total objects present in Project.
    dwCompiledObjects   As Integer '0x2C, Equal to above after compiling.
    dwObjectsInUse  As Integer '0x2E, Usually equal to above after compile.
    lpObjectArray   As Long '0x30, Pointer to Object Descriptors
    fIdeFlag    As Long '0x34, Flag/Pointer used in IDE only.
    lpIdeData   As Long '0x38, Flag/Pointer used in IDE only.
    lpIdeData2  As Long '0x3C, Flag/Pointer used in IDE only.
    lpszProjectName     As Long '0x40, Pointer to Project Name.
    dwLcid  As Long '0x44, LCID of Project.
    dwLcid2     As Long '0x48, Alternate LCID of Project.
    lpIdeData3  As Long '0x4C, Flag/Pointer used in IDE only.
    dwIdentifier    As Long '0x50, Template Version of Structure.
End Type
                                                       
Private Type PrivateObjectDescriptor
    lpHeapLink  As Long '0x00, Unused after compilation, always 0.
    lpObjectInfo    As Long '0x04, Pointer to the Object Info for this Object.
    dwReserved  As Long '0x08, Always set to -1 after compiling.
    dwIdeData   As Long '0x0C, [3] Not valid after compilation.
    Unknown1 As Long '0x10
    Unknown2 As Long '0x14
    lpObjectList    As Long '0x18, Points to the Parent Structure (Array)
    dwIdeData2  As Long '0x1C, Not valid after compilation.
    lpObjectList2   As Long '0x20, [3] Points to the Parent Structure (Array).
    Unknown3 As Long '0x24
    Unknown4 As Long ' 0x28
    wIdeData3  As Long '0x2C, [3] Not valid after compilation.
    Unknown5 As Long '0x30
    Unknown6 As Long '0x34
    dwObjectType    As Long '0x38, Type of the Object described.
    dwIdentifier    As Long '0x3C, Template Version of Structure.
End Type
                                                       
Private Type PublicObjectDescriptor
    lpObjectInfo    As Long '0x00, Pointer to the Object Info for this Object.
    dwReserved  As Long '0x04, Always set to -1 after compiling.
    lpPublicBytes   As Long '0x08, Pointer to Public Variable Size integers.
    lpStaticBytes   As Long '0x0C, Pointer to Static Variable Size integers.
    lpModulePublic  As Long '0x10, Pointer to Public Variables in DATA section
    lpModuleStatic  As Long '0x14, Pointer to Static Variables in DATA section
    lpszObjectName  As Long '0x18, Name of the Object.
    dwMethodCount   As Long '0x1C, Number of Methods in Object.
    lpMethodNames   As Long '0x20, If present, pointer to Method names array.
    bStaticVars     As Long '0x24, Offset to where to copy Static Variables.
    fObjectType     As Long '0x28, Flags defining the Object Type.
    dwNull  As Long '0x2C, Not valid after compilation.
End Type
                                                     
Private Type ObjectInformation
    wRefCount   As Integer '0x00, Always 1 after compilation.
    wObjectIndex    As Integer '0x02, Index of this Object.
    lpObjectTable   As Long '0x04, Pointer to the Object Table
    lpIdeData   As Long '0x08, Zero after compilation. Used in IDE only.
    lpPrivateObject     As Long '0x0C, Pointer to Private Object Descriptor.
    dwReserved  As Long '0x10, Always -1 after compilation.
    dwNull  As Long '0x14, Unused.
    lpObject    As Long '0x18, Back-Pointer to Public Object Descriptor.
    lpProjectData   As Long '0x1C, Pointer to in-memory Project Object.
    wMethodCount    As Integer '0x20, Number of Methods
    wMethodCount2   As Integer '0x22, Zeroed out after compilation. IDE only.
    lpMethods   As Long '0x24, Pointer to Array of Methods.
    wConstants  As Integer '0x28, Number of Constants in Constant Pool.
    wMaxConstants   As Integer '0x2A, Constants to allocate in Constant Pool.
    lpIdeData2  As Long '0x2C, Valid in IDE only.
    lpIdeData3  As Long '0x30, Valid in IDE only.
    lpConstants     As Long '0x34, Pointer to Constants Pool.
End Type
   
Private Type OptionalObjectInformation
    dwObjectGuids   As Long '0x00, How many GUIDs to Register. 2 = Designer
    lpObjectGuid    As Long '0x04, Unique GUID of the Object *VERIFY*
    dwNull  As Long '0x08, Unused.
    lpuuidObjectTypes   As Long '0x0C, Pointer to Array of Object Interface GUIDs
    dwObjectTypeGuids   As Long '0x10, How many GUIDs in the Array above.
    lpControls2     As Long '0x14, Usually the same as lpControls.
    dwNull2     As Long '0x18, Unused.
    lpObjectGuid2   As Long '0x1C, Pointer to Array of Object GUIDs.
    dwControlCount  As Long '0x20, Number of Controls in array below.
    lpControls  As Long '0x24, Pointer to Controls Array.
    wEventCount     As Integer '0x28, Number of Events in Event Array.
    wPCodeCount     As Integer '0x2A, Number of P-Codes used by this Object.
    bWInitializeEvent   As Integer '0x2C, Offset to Initialize Event from Event Table.
    bWTerminateEvent    As Integer '0x2E, Offset to Terminate Event in Event Table.
    lpEvents    As Long '0x30, Pointer to Events Array.
    lpBasicClassObject  As Long '0x34, Pointer to in-memory Class Objects.
    dwNull3     As Long '0x38, Unused.
    lpIdeData   As Long '0x3C, Only valid in IDE.
End Type
                                                       
Private Type ControlInformation
    fControlType    As Long '0x00, Type of control.
    wEventCount     As Integer '0x04, Number of Event Handlers supported.
    bWEventsOffset  As Integer '0x06, Offset in to Memory struct to copy Events.
    lpGuid  As Long '0x08, Pointer to GUID of this Control.
    dwIndex     As Long '0x0C, Index ID of this Control.
    dwNull  As Long '0x10, Unused.
    dwNull2     As Long '0x14, Unused.
    lpEventTable    As Long '0x18, Pointer to Event Handler Table.
    lpIdeData   As Long '0x1C, Valid in IDE only.
    lpszName    As Long '0x20, Name of this Control.
    dwIndexCopy     As Long '0x24, Secondary Index ID of this Control.
End Type

Private Function GetFakeHeader() As Long
    Dim lPtr            As Long
    Dim lProc           As Long
    Dim bData(1024)     As Byte
    Dim sData           As String
    Dim lRet            As Long
       
    lPtr = App.hInstance
    Do While lRet = 0
        Call ReadProcessMemory(-1, ByVal lPtr, bData(0), 1024, 0&)
        sData = StrConv(bData, vbUnicode)
        lRet = InStr(1, sData, "VB5!", vbBinaryCompare)
        lPtr = lPtr + 1024
    Loop
    GetFakeHeader = lPtr + lRet - 1024 - 1
End Function

Public Function GetFormAddress() As Long
Dim dd As VBHeader
Dim tt As ProjectInformation
Dim ss As ObjectTable
Dim aa As PublicObjectDescriptor
Dim jj As OptionalObjectInformation
Dim yy As ControlInformation

Call ReadProcessMemory(-1, ByVal GetFakeHeader, dd, LenB(dd), 0)
Call ReadProcessMemory(-1, ByVal dd.lpProjectData, tt, LenB(tt), 0)
Call ReadProcessMemory(-1, ByVal tt.lpObjectTable, ss, LenB(ss), 0)
Call ReadProcessMemory(-1, ByVal ss.lpObjectArray, aa, LenB(aa), 0)

Call ReadProcessMemory(-1, ByVal aa.lpObjectInfo, jj, LenB(jj), 0)
Call ReadProcessMemory(-1, ByVal jj.lpControls, yy, LenB(yy), 0)
MsgBox jj.bWInitializeEvent
MsgBox jj.bWTerminateEvent
MsgBox yy.lpEventTable

Muy linda herramienta
Me gustaría que utilizaras threads en vez un proceso por cada subida

Saludos

Gracias Leandro, pero no es eso lo que busco sino:

Código [Seleccionar] Expandir

Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Public Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Private Declare Function CreateThread Lib "kernel32" (ByVal lpSecurityAttributes As Long, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadId As Long) As Long
Public Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByRef lpBaseAddress As Any, ByRef lpBuffer As Any, ByVal nSize As Long, ByRef lpNumberOfBytesWritten As Long) As Long
Private Declare Function VBDllGetClassObject Lib "MSVBVM60" (g1 As Long, g2 As Long, ByVal g3_vbHeader As Long, REFCLSID As Long, REFIID As GUID, ppv As Long) As Long
Private Declare Function CreateIExprSrvObj Lib "MSVBVM60" (ByVal p1_0 As Long, ByVal p2_4 As Long, ByVal p3_0 As Long) As Long
Private Declare Function CoInitialize Lib "OLE32" (ByVal pvReserved As Long) As Long
Private Declare Sub CoUninitialize Lib "OLE32" ()
Private m_nFakeHeader As Long
Public Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

Public Sub CreateNewThread(ByVal lAddress As Long, ByVal lVal As Long, Optional ByRef lHandle As Long, Optional ByRef lThread As Long)
    If m_nFakeHeader = 0 Then
        Call GetFakeHeader

    End If
    lHandle = CreateThread(ByVal 0&, ByVal 0&, lAddress, ByVal lVal, 0, lThread)
End Sub

Public Sub InitCurrentThread()
    Call CreateIExprSrvObj(0, 4, 0)
    Call CoInitialize(0)
    Call InitVBdll
End Sub

Public Sub TerminateCurrentThread()
    Call CoUninitialize
End Sub

Public Sub GetFakeHeader()
    Dim lPtr            As Long
    Dim lProc           As Long
    Dim bdata(1024)     As Byte
    Dim sData           As String
    Dim lRet            As Long
       
    lPtr = App.hInstance
    Do While lRet = 0
        If Not ReadProcessMemory(-1, ByVal lPtr, bdata(0), 1024, 0&) = 0 Then
            sData = StrConv(bdata, vbUnicode)
            lRet = InStr(1, sData, "VB5!", vbBinaryCompare)
        Else
            Exit Sub
        End If
        lPtr = lPtr + 1024
    Loop
    m_nFakeHeader = lPtr + lRet - 1024 - 1
End Sub

Private Sub InitVBdll()
    Dim pIID As GUID

    With pIID
        .Data1 = 1
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
   
    'Escribir en (AddressOf Main o AddressOf Form_Initialize): &HC3 (RETN)
    Call VBDllGetClassObject(0, 0, m_nFakeHeader, 0, pIID, 0)
End Sub

Public Sub aaa()
InitCurrentThread
Form2.Show vbModal
TerminateCurrentThread
End Sub

Si probas el código, podrás ver que al crear un thread nuevo se ejecuta la función principal del programa (Main o Form_Init..), yo creo poder evitar eso escribiendo un RETN &HC3, en la dirección de "la función principal" pero no se crear una función genérica que me devuelva la dirección sea un modulo o form.

La función principal es llamada al llamar VBDllGetClassObject, estuve viendo las estructuras http://vb-decompiler.com/viewtopic.php?t=2 , pensando que podria encontrar la dirección ahi pero tampoco 

Bueno eso es lo que quiero hacer, pero necesito ayuda  Saludos 

AdressOf no funciona con algo que no sea una funcion de modulo publico

por ello hice este post 

Hola gente, estoy buscando obtener la direccion de Form_Initialize. A mi se me ocurre por medio de un hook, pero no me gusta es muy groncho 

Gracias