ConnectToConnectionPointでDocumentCompleteイベント

Class1.cls

Option Explicit


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

Private Declare PtrSafe _
Function IIDFromString Lib "ole32.dll" ( _
    ByVal lpsz As LongPtr, _
    lpiid As GUID _
) As Long

Private Declare PtrSafe Function ConnectToConnectionPoint _
                      Lib "shlwapi" Alias "#168" _
       (ByVal punk As stdole.IUnknown, _
        ByRef riidEvent As GUID, _
        ByVal fConnect As Long, _
        ByVal punkTarget As stdole.IUnknown, _
        ByRef pdwCookie As Long, _
        Optional ByVal ppcpOut As LongPtr) As Long

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private cookie As Long
Private iid As GUID
Private cls2 As Class2

Private Sub Class_Initialize()

    'DWebBrowserEvents2
    Const s = "{34A715A0-6587-11D0-924A-0020AFC7AC4D}"
    
    Dim hr As Long
    hr = IIDFromString(StrPtr(s), iid)

    Debug.Print hr
    Set ie = CreateObject("InternetExplorer.application")
    ie.Visible = True
    
    Dim cls3 As Class3
    Set cls3 = New Class3
    
   ie.navigate "https://www.google.co.jp/"

    While ie.Busy
        Sleep 1&
    Wend
    
    
    ie.document.addEventListener "DOMContentLoaded", cls3, True
    

    Set cls2 = New Class2
    hr = ConnectToConnectionPoint(cls2, iid, 1, ie, cookie)
    Debug.Print Hex(hr), cookie
    If hr <> 0 Then Exit Sub
    

End Sub

Private Sub Class_Terminate()

    Dim hr As Long
    hr = ConnectToConnectionPoint(Nothing, iid, 0, ie, cookie)
    Debug.Print Hex(hr), cookie
    If hr <> 0 Then Exit Sub

End Sub

Class2.cls

Option Explicit



Public Sub DocumentComplete(ByVal pDisp As Object, URL As Variant)
Attribute hoge.VB_UserMemID = 259
    Debug.Print "呼ばれたお(・∀・)"

End Sub

Class3.cls

Option Explicit


Sub foo()
Attribute TEST.VB_UserMemId = &H0

    Debug.Print "call!", "cls3"

End Sub

Module1.bas

Option Explicit

Public ie As Object
Private cls As Class1

Sub Main()

    Set cls = New Class1

End Sub

Sub end_()

    Set cls = Nothing
    
End Sub