Обработчик событий WebBrowser

После создания WebBrowser в своей библиотеке window9, мне всегда хотелось понять как отлавливать все его основные события. И вот человек, который называет себя ShadEx , дал ссылку на незаконченный код подобия браузера. И хоть код был довольно сумбурный и с ошибками, мне удалось в нем уловить идею и создать более-менее адекватный пример.

В начале кода идут константы событий, которые могут отлавливаться\обрабатываться в методе COM класса "D_F_Invoke". Я в примере отловил событие открытия нового окна. Далее заблокировал его и открыл URL в имеющемся окне.

Платформа: Windows (нужна библиотека window9)
Автор: Станислав Будинов

#INCLUDE "window9.bi"
#INCLUDE "crt.bi"

'{ Константы Обработчика событий WebBrowser
#DEFINE DISPID_BEFORENAVIGATE     100   ' this is sent before navigation To give a chance To abort
#DEFINE DISPID_NAVIGATECOMPLETE   101   ' in async, this is sent when we have enough To show
#DEFINE DISPID_STATUSTEXTCHANGE   102
#DEFINE DISPID_QUIT               103
#DEFINE DISPID_DOWNLOADCOMPLETE   104
#DEFINE DISPID_COMMANDSTATECHANGE 105
#DEFINE DISPID_DOWNLOADBEGIN      106
#DEFINE DISPID_NEWWINDOW          107   ' sent when a new window should be created
#DEFINE DISPID_PROGRESSCHANGE     108   ' sent when download progress is updated
#DEFINE DISPID_WINDOWMOVE         109   ' sent when main window has been moved
#DEFINE DISPID_WINDOWRESIZE       110   ' sent when main window has been sized
#DEFINE DISPID_WINDOWACTIVATE     111   ' sent when main window has been activated
#DEFINE DISPID_PROPERTYCHANGE     112   ' sent when the PutProperty method is called
#DEFINE DISPID_TITLECHANGE        113   ' sent when the document title changes
#DEFINE DISPID_TITLEICONCHANGE    114   ' sent when the top level window icon may have changed.

#DEFINE DISPID_FRAMEBEFORENAVIGATE    200
#DEFINE DISPID_FRAMENAVIGATECOMPLETE  201
#DEFINE DISPID_FRAMENEWWINDOW         204

#DEFINE DISPID_PRINTTEMPLATEINSTANTIATION 225
#DEFINE DISPID_PRINTTEMPLATETEARDOWN      226

#DEFINE DISPID_BEFORENAVIGATE2      250   ' hyperlink clicked on
#DEFINE DISPID_NEWWINDOW2           251
#DEFINE DISPID_NAVIGATECOMPLETE2    252   ' UIActivate new document
#DEFINE DISPID_ONQUIT               253
#DEFINE DISPID_ONVISIBLE            254   ' sent when the window goes visible/hidden
#DEFINE DISPID_ONTOOLBAR            255   ' sent when the toolbar should be shown/hidden
#DEFINE DISPID_ONMENUBAR            256   ' sent when the menubar should be shown/hidden
#DEFINE DISPID_ONSTATUSBAR          257   ' sent when the statusbar should be shown/hidden
#DEFINE DISPID_ONFULLSCREEN         258   ' sent when kiosk mode should be on/off
#DEFINE DISPID_DOCUMENTCOMPLETE     259   ' new document goes ReadyState_Complete
#DEFINE DISPID_ONTHEATERMODE        260   ' sent when theater mode should be on/off
#DEFINE DISPID_ONADDRESSBAR         261   ' sent when the address bar should be shown/hidden
#DEFINE DISPID_WINDOWSETRESIZABLE   262   ' sent To set the style of the host window frame
#DEFINE DISPID_WINDOWCLOSING        263   ' sent before script window.close closes the window
#DEFINE DISPID_WINDOWSETLEFT        264   ' sent when the put_left method is called on the WebOC
#DEFINE DISPID_WINDOWSETTOP         265   ' sent when the put_top method is called on the WebOC
#DEFINE DISPID_WINDOWSETWIDTH       266   ' sent when the put_width method is called on the WebOC
#DEFINE DISPID_WINDOWSETHEIGHT      267   ' sent when the put_height method is called on the WebOC
#DEFINE DISPID_CLIENTTOHOSTWINDOW   268   ' sent during window.open To request conversion of dimensions
#DEFINE DISPID_SETSECURELOCKICON    269   ' sent To suggest the appropriate security icon To show
#DEFINE DISPID_FILEDOWNLOAD         270   ' Fired To indicate the File Download dialog is opening
#DEFINE DISPID_NAVIGATEERROR        271   ' Fired To indicate the a binding error has occured
#DEFINE DISPID_PRIVACYIMPACTEDSTATECHANGE   272  ' Fired when the user's browsing experience is impacted
#DEFINE DISPID_NEWWINDOW3           273
'}

Dim Shared  IID_DWebBrowserEvents2 As IID = Type(&h34A715A0, &h6587, &h11D0, {&h92, &h4a, &h00, &h20, &haf, &hc7, &hac, &h4d})

Dim Shared bra As IWebBrowser2 Ptr

'{ Класс обработчика

Type DispatchFunctionsVtbl_ As DispatchFunctionsVtbl

Type  DispatchFunctions
    lpVtbl  As  DispatchFunctionsVtbl_ Ptr
End Type

Type DispatchFunctionsVtbl
    QueryInterface As Function (pDf As DispatchFunctions Ptr, iid As REFIID, ppv As LPVOID Ptr) As HRESULT
    AddRef As Function (pDf As DispatchFunctions Ptr) As Ulong
    Release As Function (pDf As DispatchFunctions Ptr) As Ulong
    GetTypeInfoCount As Function (Byref D_O As DispatchFunctions Ptr, pctinfo As UINT Ptr) As HRESULT
    GetTypeInfo As Function (Byref D_O As DispatchFunctions Ptr, iTInfo As UINT, lcid As LCID, ppTInfo As LPTYPEINFO Ptr) As HRESULT
    GetIDsOfNames As Function (Byref D_O As DispatchFunctions Ptr, riid As IID Ptr, rgszNames As LPOLESTR Ptr, cNames As UINT, lcid As LCID, rgDispId As DISPID Ptr) As HRESULT
    Invoke As Function (Byref D_O As DispatchFunctions Ptr, dispIdMember As DISPID, riid As IID Ptr, lcid As LCID, wFlags As WORD, Byref pDispParams As DISPPARAMS Ptr, pVarResult As VARIANT_ Ptr, pExcepInfo As EXCEPINFO Ptr, puArgErr As UINT Ptr) As HRESULT
End Type

Type Obj_D_F
    Df  As DispatchFunctions
    cRef As Integer
End Type

Function D_F_QueryInterface (pDf As DispatchFunctions Ptr, iid As REFIID, ppv As LPVOID Ptr) As HRESULT

    Dim  pThis As Obj_D_F  Ptr

    pThis   = Cast(Obj_D_F  Ptr,pDf)

    If IsEqualIID( iid, @IID_IUnknown) Then
        *ppv = @(pThis->Df)
        pDf->lpVtbl->AddRef(pDf)
        Return  S_OK

    Elseif IsEqualIID( iid, @IID_IDispatch) Then
        *ppv = @(pThis->Df)
        pDf->lpVtbl->AddRef(pDf)
        Return  S_OK
    End If

    ppv = NULL
    Function =  E_NOINTERFACE
End Function

Function D_F_AddRef(pDf As DispatchFunctions Ptr) As Ulong
    Dim   pThis As Obj_D_F  Ptr
    pThis = Cast(Obj_D_F  Ptr,pDf)
    pThis->cRef +=1
    Function =  pThis->cRef
End Function

Function D_F_Release(pDf As DispatchFunctions Ptr) As Ulong
    Dim   pThis As Obj_D_F  Ptr
    pThis = Cast(Obj_D_F  Ptr,pDf)
    pThis->cRef -=1
    Function = pThis->cRef
End Function

Function D_F_GetTypeInfoCount(Byref D_O As DispatchFunctions Ptr, pctinfo As UINT Ptr) As HRESULT
    Return 0
End Function

Function D_F_GetTypeInfo(Byref D_O As DispatchFunctions Ptr, iTInfo As UINT, lcid As LCID, ppTInfo As LPTYPEINFO Ptr ) As HRESULT
    Return 0
End Function

Function D_F_GetIDsOfNames(Byref D_O As DispatchFunctions Ptr, riid As IID Ptr, rgszNames As LPOLESTR Ptr, cNames As UINT, lcid As LCID, rgDispId As DISPID Ptr) As HRESULT
    Return 0
End Function

Function D_F_Invoke(Byref D_O As DispatchFunctions Ptr, dispIdMember As DISPID, riid As IID Ptr, lcid As LCID, wFlags As WORD, Byref pDispParams As DISPPARAMS Ptr, pVarResult As VARIANT_ Ptr, pExcepInfo As EXCEPINFO Ptr, puArgErr As UINT Ptr) As HRESULT
    If dispIDMember = DISPID_DOWNLOADCOMPLETE Then
        ? "DOWNLOADCOMPLETE!"
    Elseif dispIDMember = DISPID_NEWWINDOW2 Then
        Dim params1 As VARIANT Ptr = Cast(VARIANT Ptr,pDispParams)
        *params1->pboolVal = VARIANT_TRUE
    Elseif dispIDMember = DISPID_NEWWINDOW3 Then
        Dim params1 As VARIANT Ptr = Cast(VARIANT Ptr,pDispParams)
        WebGadgetNavigate(Cast(Integer Ptr,bra),UTFTOASCII( params1->bstrVal))
    Endif
    Return 0
End Function

'}

Dim dispatchFunc As DispatchFunctionsVtbl = Type(@D_F_QueryInterface(),@D_F_AddRef(),@D_F_Release(),@D_F_GetTypeInfoCount(),@D_F_GetTypeInfo(),@D_F_GetIDsOfNames(),@D_F_Invoke())
Dim connectionPointContainer As IConnectionPointContainer Ptr
Dim connectionPoint As IConnectionPoint Ptr
Dim dispatchObject As Obj_D_F
dispatchObject.Df.lpVtbl = @dispatchFunc
Dim dispatch As IDispatch Ptr = Cast(IDispatch Ptr,@dispatchObject)
Dim Cookie As Integer


OpenWindow("",0,0,640,480)

bra = Cast(IWebBrowser2 Ptr,WebGadget(1,0,0,620,440, "http://mneniya.ucoz.ru/",WS_VSCROLL Or WS_HSCROLL,WS_EX_CLIENTEDGE))
bra->lpVtbl->QueryInterface(bra,@IID_IConnectionPointContainer, @connectionPointContainer)
connectionPointContainer->lpVtbl->FindConnectionPoint(connectionPointContainer,@IID_DWebBrowserEvents2, @connectionPoint)
connectionPoint->lpVtbl->Advise(connectionPoint,Cast(IUnknown Ptr, dispatch), @Cookie)

Do:Loop Until WaitEvent() = EventClose

FreeBasic

Обработчик событий WebBrowser