VB6 impl of IDocHostUIHandler for WebBrowser site

cWebBrowserExtension

Option Explicit
DefObj A-Z
Private Const STR_MODULE_NAME As String = "cWebBrowserExtension"

...

Private WithEvents m_oCtl       As DirectWebBrowser
Private WithEvents m_oCtlExt    As VBControlExtender
Private m_uHook                 As UcsDocHostHookData
Private m_oExternal             As Object

...

Property Get External() As Object
    Set External = m_oExternal
End Property

Property Set External(oValue As Object)
    Set m_oExternal = oValue
End Property

...

Friend Function frInit(oCtl As VBControlExtender) As Boolean
    Const FUNC_NAME     As String = "frInit"
    
    On Error GoTo EH
    '--- member vars
    Set m_oCtlExt = oCtl
    Set m_oCtl = m_oCtlExt.Object
    Set m_cHistory = New Collection
    m_bEnabled = True
    m_sInstanceName = TypeName(m_oCtlExt.Parent) & "." & m_oCtlExt.Name
    #If DebugMode Then
        DebugInstanceName m_sInstanceName, m_sDebugID
    #End If
    m_eVisible = ucsTri_Undefined
    m_eUIFlags = DOCHOSTUIFLAG_BROWSER
    m_bAllowContextMenu = True
    m_oCtl.RegisterAsBrowser = True
    InitDocHostHook m_uHook, m_oCtlExt, Me
    If InIde Then
        WaitDocHostHook m_uHook
    End If
    '--- success
    frInit = True
    Exit Function
EH:
    RaiseError FUNC_NAME
End Function

Friend Function frGetExternal() As Object
    Set frGetExternal = m_oExternal
End Function

mdDocHostUIHandler

Option Explicit
Private Const MODULE_NAME As String = "mdDocHostUIHandler"

#Const Logging = DebugMode

'==============================================================================
' API
'==============================================================================

Private Const WM_KEYDOWN                    As Long = &H100

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, src As Any, ByVal l As Long)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Type GUID
    Data1           As Long
    Data2           As Long
    Data3           As Long
    Data4           As Long
End Type

'==============================================================================
' Public enums
'==============================================================================

Public Enum DOCHOSTUIDBLCLK
    DOCHOSTUIDBLCLK_DEFAULT = 0
    DOCHOSTUIDBLCLK_SHOWPROPERTIES = 1
    DOCHOSTUIDBLCLK_SHOWCODE = 2
End Enum

Public Enum DOCHOSTUIFLAG
    DOCHOSTUIFLAG_DIALOG = 1
    DOCHOSTUIFLAG_DISABLE_HELP_MENU = 2
    DOCHOSTUIFLAG_NO3DBORDER = 4
    DOCHOSTUIFLAG_SCROLL_NO = 8
    DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE = &H10
    DOCHOSTUIFLAG_OPENNEWUI = &H20
    DOCHOSTUIFLAG_DISABLE_OFFSCREEN = &H40
    DOCHOSTUIFLAG_FLAT_SCROLLBAR = &H80
    DOCHOSTUIFLAG_DIV_BLOCKDEFAULT = &H100
    DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY = &H200
    DOCHOSTUIFLAG_OVERRIDEBEHAVIORFACTORY = &H400
    DOCHOSTUIFLAG_CODEPAGELINKEDFONTS = &H800
    DOCHOSTUIFLAG_URL_ENCODING_DISABLE_UTF8 = &H1000
    DOCHOSTUIFLAG_URL_ENCODING_ENABLE_UTF8 = &H2000
    DOCHOSTUIFLAG_ENABLE_FORMS_AUTOCOMPLETE = &H4000
    DOCHOSTUIFLAG_ENABLE_INPLACE_NAVIGATION = &H10000
    DOCHOSTUIFLAG_IME_ENABLE_RECONVERSION = &H20000
    DOCHOSTUIFLAG_BROWSER = &H12
    DOCHOSTUIFLAG_DESKTOP = &H2E
End Enum

Public Type DOCHOSTUIINFO
    cbSize          As Long
    dwFlags         As DOCHOSTUIFLAG
    dwDoubleClick   As DOCHOSTUIDBLCLK
    pchHostCss      As Long
    pchHostNS       As Long
End Type
    
Public Enum HRESULTS
    S_OK = 0
    S_FALSE = 1
    E_NOTIMPL = &H80004001
    E_NOINTERFACE = &H80004002
End Enum

Public Type UcsDocHostHookData
    pVTable         As Long
    OrigVTablePtr   As Long
    VTable(0 To 20) As Long '--- ToDo: da se utichnqt kolko tochno sa methodite na naj-golemiq interface kojto impl IUnknown!!
    pUnk            As VBOleGuids3.IUnknown
    Sink            As cWebBrowserExtension '-- un-addref'd
    Live            As Boolean
End Type

'==============================================================================
' Constants and member variables
'==============================================================================

Private Const GUID_DOCHOSTHANDLER_DATA1     As Long = &HBD3F23C0
Private Const GUID_DOCHOSTHANDLER_DATA2     As Long = &H11CFD43E
Private Const GUID_DOCHOSTHANDLER_DATA3     As Long = &HAA003B89
Private Const GUID_DOCHOSTHANDLER_DATA4     As Long = &H1ACEBD00

Private m_cSinks            As Collection
Private m_lVTable(0 To 17)  As Long

'==============================================================================
' Error handling
'==============================================================================

Private Sub PrintError(sFunction As String)
    PushError
    PopPrintError sFunction, MODULE_NAME
End Sub

'==============================================================================
' Functions
'==============================================================================

Public Sub InitDocHostHook( _
            uData As UcsDocHostHookData, _
            pBrowser As DirectWebBrowser, _
            oSink As cWebBrowserExtension)
    Const FUNC_NAME     As String = "InitDocHostHook"
    Dim pCtl            As IOleObject
    Dim pSite           As IOleClientSite
    
    On Error GoTo EH
    If Not GApp.Preferences.DebugEnableDocHostHook Then
        Exit Sub
    End If
    If m_lVTable(0) = 0 Then
        m_lVTable(0) = pvAddr(AddressOf QueryInterface)
        m_lVTable(1) = pvAddr(AddressOf AddRef)
        m_lVTable(2) = pvAddr(AddressOf Release)
        m_lVTable(3) = pvAddr(AddressOf ShowContextMenu)
        m_lVTable(4) = pvAddr(AddressOf GetHostInfo)
        m_lVTable(5) = pvAddr(AddressOf ShowUI)
        m_lVTable(6) = pvAddr(AddressOf HideUI)
        m_lVTable(7) = pvAddr(AddressOf UpdateUI)
        m_lVTable(8) = pvAddr(AddressOf EnableModeless)
        m_lVTable(9) = pvAddr(AddressOf OnDocWindowActivate)
        m_lVTable(10) = pvAddr(AddressOf OnFrameWindowActivate)
        m_lVTable(11) = pvAddr(AddressOf ResizeBorder)
        m_lVTable(12) = pvAddr(AddressOf TranslateAccelerator)
        m_lVTable(13) = pvAddr(AddressOf GetOptionKeyPath)
        m_lVTable(14) = pvAddr(AddressOf GetDropTarget)
        m_lVTable(15) = pvAddr(AddressOf GetExternal)
        m_lVTable(16) = pvAddr(AddressOf TranslateUrl)
        m_lVTable(17) = pvAddr(AddressOf FilterDataObject)
        Set m_cSinks = New Collection
    End If
    '--- get interfaces
    Set pCtl = pBrowser
    Set pSite = pCtl.GetClientSite
    With uData
        '--- check if already hooked
        If Not .Sink Is Nothing Then
            TerminateDocHostHook uData, pBrowser
        End If
        '--- setup light-weight object
        .pVTable = VarPtr(m_lVTable(0))
        Set .pUnk = pSite
        Call CopyMemory(.Sink, ObjPtr(oSink), 4)
        '--- hook QI
        Call CopyMemory(.OrigVTablePtr, ByVal ObjPtr(pSite), 4)
        Call CopyMemory(.VTable(0), ByVal .OrigVTablePtr, (UBound(.VTable) + 1) * 4)
        .VTable(0) = pvAddr(AddressOf QueryInterface)
        Call CopyMemory(ByVal ObjPtr(pSite), VarPtr(.VTable(0)), 4)
        .Live = False
    End With
    '--- persist mapping
    m_cSinks.Add VarPtr(uData), "#" & ObjPtr(pSite)
    '--- refresh browser and IDocHostUIHandler
    If LenB(pBrowser.LocationURL) <> 0 Then
        #If Logging Then
            DebugPrint FUNC_NAME, MODULE_NAME, "Before navigate to " & pBrowser.LocationURL, 2
        #End If
        pBrowser.Navigate pBrowser.LocationURL
    Else
        uData.Live = True
    End If
    Exit Sub
EH:
    PrintError FUNC_NAME
    Resume Next
End Sub

Public Sub TerminateDocHostHook( _
            uData As UcsDocHostHookData, _
            pBrowser As DirectWebBrowser)
    Const FUNC_NAME     As String = "TerminateDocHostHook"
    Dim pSite           As IOleClientSite
    
    On Error GoTo EH
    With uData
        If Not .Sink Is Nothing And uData.pVTable <> 0 Then
            '--- clear weak reference
            Call CopyMemory(.Sink, 0&, 4)
            '--- unhook QI
            Set pSite = .pUnk
            Call CopyMemory(ByVal ObjPtr(pSite), .OrigVTablePtr, 4)
            '--- first, release the last reference to IDocHostUIHandler interface
'            DebugPrint FUNC_NAME, MODULE_NAME, "Before navigate to " & pBrowser.LocationURL, 2
'            pBrowser.Navigate pBrowser.LocationURL
            #If Logging Then
                DebugPrint FUNC_NAME, MODULE_NAME, "Before navigate to " & "about:blank", 2
            #End If
            pBrowser.Navigate "about:blank"
            '--- then clear reference to site (used in IDocHostUIHandler::release)
'            DoEvents
'            Set .pUnk = Nothing
            '--- remove mapping
            m_cSinks.Remove "#" & ObjPtr(pSite)
        End If
    End With
    Exit Sub
EH:
    PrintError FUNC_NAME
    Resume Next
End Sub

Public Sub WaitDocHostHook(uData As UcsDocHostHookData)
    Const FUNC_NAME     As String = "WaitDocHostHook"
    Dim dblTimer        As Double
    
    On Error GoTo EH
    If Not uData.Sink Is Nothing And uData.pVTable <> 0 Then
        #If Logging Then
            DebugPrint FUNC_NAME, MODULE_NAME, "Before loop", 2
        #End If
        dblTimer = DateTimer
        Do While Not uData.Live And dblTimer + 3 > DateTimer
            SpinThreadMessagePump
            Call Sleep(1)
        Loop
        #If Logging Then
            DebugPrint FUNC_NAME, MODULE_NAME, "After loop", 2
        #End If
    End If
    Exit Sub
EH:
    PrintError FUNC_NAME
    Resume Next
End Sub

'= private ====================================================================

Private Function pvAddr(ByVal pfn As Long) As Long
    pvAddr = pfn
End Function

'= IDocHostUIHandler interface ================================================

Private Function QueryInterface(ByVal pSite As VBOleGuids3.IOleClientSite, riid As GUID, pvObj As Long) As Long
    Const FUNC_NAME     As String = "QueryInterface"
    Dim lPtr            As Long
    
    pvInitVbRuntime
    On Error GoTo EH
    'Debug.Print "DocHostUIHandler: QueryInterface pSite="; Hex(ObjPtr(pSite)); " QI {"; Hex(riid.Data1); "-"; Hex(riid.Data2); "-"; Hex(riid.Data3); "-"; Hex(riid.Data4); "}"
    If riid.Data1 = GUID_DOCHOSTHANDLER_DATA1 Then
        If riid.Data2 = GUID_DOCHOSTHANDLER_DATA2 Then
            If riid.Data3 = GUID_DOCHOSTHANDLER_DATA3 Then
                If riid.Data4 = GUID_DOCHOSTHANDLER_DATA4 Then
                    'Debug.Print "DocHostUIHandler: QueryInterface pvObj=";
                    'Debug.Print Hex(m_cSinks("#" & ObjPtr(pSite))); Timer
                    pvObj = m_cSinks("#" & ObjPtr(pSite))
                    pSite.AddRef
                    QueryInterface = S_OK
                    Exit Function
                End If
            End If
        End If
    End If
    On Error Resume Next
    '--- restore orig VTable
    lPtr = m_cSinks("#" & ObjPtr(pSite)) + 4
    If lPtr = 0 Then
        QueryInterface = E_NOINTERFACE
        Exit Function
    End If
    Call CopyMemory(ByVal ObjPtr(pSite), ByVal lPtr, 4)
    QueryInterface = pSite.QueryInterface(ByVal VarPtr(riid), pvObj)
    '--- re-set QI hook
    lPtr = m_cSinks("#" & ObjPtr(pSite)) + 8
    Call CopyMemory(ByVal ObjPtr(pSite), lPtr, 4)
    Exit Function
EH:
    PrintError FUNC_NAME
    Resume Next
End Function

Private Function AddRef(This As UcsDocHostHookData) As Long
    Const FUNC_NAME     As String = "AddRef"
    
    pvInitVbRuntime
    On Error GoTo EH
    'Debug.Print "DocHostUIHandler: AddRef "; Timer
    AddRef = This.pUnk.AddRef
    Exit Function
EH:
    PrintError FUNC_NAME
    Resume Next
End Function

Private Function Release(This As UcsDocHostHookData) As Long
    Const FUNC_NAME     As String = "Release"
    
    pvInitVbRuntime
    On Error GoTo EH
    'Debug.Print "DocHostUIHandler: Release "; Timer
    If Not This.pUnk Is Nothing Then
        Release = This.pUnk.Release
    End If
    If This.Sink Is Nothing Then
        Set This.pUnk = Nothing
    End If
    Exit Function
EH:
    PrintError FUNC_NAME
    Resume Next
End Function

Private Function ShowContextMenu( _
        This As UcsDocHostHookData, _
        ByVal dwContext As Long, _
        ByVal pPOINT As Long, _
        ByVal pCommandTarget As Long, _
        ByVal HTMLTagElement As Long) As Long
    Const FUNC_NAME     As String = "ShowContextMenu"
    
    pvInitVbRuntime
    On Error GoTo EH
    'Debug.Print "DocHostUIHandler: ShowContextMenu "; Timer
    If Not This.Sink Is Nothing Then
        ShowContextMenu = This.Sink.frShowContextMenu(dwContext, pPOINT, pCommandTarget, HTMLTagElement)
    Else
        ShowContextMenu = E_NOTIMPL
    End If
    Exit Function
EH:
    PrintError FUNC_NAME
    Resume Next
End Function
        
Private Function GetHostInfo( _
        This As UcsDocHostHookData, _
        pInfo As DOCHOSTUIINFO) As Long
    Const FUNC_NAME     As String = "GetHostInfo"
    
    pvInitVbRuntime
    On Error GoTo EH
    'Debug.Print "DocHostUIHandler: GetHostInfo "; Timer
    If Not This.Sink Is Nothing Then
        GetHostInfo = This.Sink.frGetHostInfo(pInfo)
    Else
        GetHostInfo = E_NOTIMPL
    End If
    Exit Function
EH:
    PrintError FUNC_NAME
    Resume Next
End Function

Private Function ShowUI( _
        This As UcsDocHostHookData, _
        ByVal dwID As Long, _
        ByVal pActiveObject As Long, _
        ByVal pCommandTarget As Long, _
        ByVal pFrame As Long, _
        ByVal pDoc As Long) As Long
    #If This And dwID And pActiveObject And pCommandTarget And pFrame And pDoc Then '--- touch
    #End If
    'Debug.Print "DocHostUIHandler: ShowUI "; Timer
    ShowUI = E_NOTIMPL
End Function

Private Function HideUI( _
        This As UcsDocHostHookData) As Long
    #If This Then '--- touch
    #End If
    'Debug.Print "DocHostUIHandler: HideUI "; Timer
    HideUI = E_NOTIMPL
End Function

Private Function UpdateUI( _
        This As UcsDocHostHookData) As Long
    #If This Then '--- touch
    #End If
    This.Live = True
    'Debug.Print "DocHostUIHandler: UpdateUI "; Timer
    UpdateUI = E_NOTIMPL
End Function

Private Function EnableModeless( _
        This As UcsDocHostHookData, _
        ByVal fEnable As Long) As Long
    #If This And fEnable Then '--- touch
    #End If
    'Debug.Print "DocHostUIHandler: EnableModeless "; Timer
    EnableModeless = E_NOTIMPL
End Function

Private Function OnDocWindowActivate( _
        This As UcsDocHostHookData, _
        ByVal fActivate As Long) As Long
    #If This And fActivate Then '--- touch
    #End If
    'Debug.Print "DocHostUIHandler: OnDocWindowActivate "; Timer
    OnDocWindowActivate = E_NOTIMPL
End Function

Private Function OnFrameWindowActivate( _
        This As UcsDocHostHookData, _
        ByVal fActivate As Long) As Long
    #If This And fActivate Then '--- touch
    #End If
    'Debug.Print "DocHostUIHandler: OnFrameWindowActivate "; Timer
    OnFrameWindowActivate = E_NOTIMPL
End Function

Private Function ResizeBorder( _
        This As UcsDocHostHookData, _
        ByVal prcBorder As Long, _
        ByVal puiWindow As Long, _
        ByVal fRameWindow As Long) As Long
    #If This And prcBorder And puiWindow And fRameWindow Then '--- touch
    #End If
    'Debug.Print "DocHostUIHandler: ResizeBorder "; Timer
    ResizeBorder = E_NOTIMPL
End Function

Private Function TranslateAccelerator( _
        This As UcsDocHostHookData, _
        lpMsg As MSG, _
        ByVal pguidCmdGroup As Long, _
        ByVal nCmdID As Long) As Long
    Const FUNC_NAME     As String = "TranslateAccelerator"
    Dim nKeyCode        As Integer
    
    pvInitVbRuntime
    On Error GoTo EH
    #If This And pguidCmdGroup And nCmdID Then '--- touch
    #End If
    'Debug.Print "DocHostUIHandler: TranslateAccelerator "; Timer
    TranslateAccelerator = S_FALSE
    If lpMsg.Message = WM_KEYDOWN Then
        If GetShiftState() <> 0 Then ' Or (lpMsg.wParam >= vbKeyF1 And lpMsg.wParam <= vbKeyF16)
            If Not This.Sink Is Nothing Then
                nKeyCode = PeekInteger(VarPtr(lpMsg.wParam))
                This.Sink.Form.frHandleKeyDown nKeyCode, GetShiftState()
                If nKeyCode = 0 Then
                    TranslateAccelerator = S_OK
                End If
            End If
        End If
    End If
    Exit Function
EH:
    PrintError FUNC_NAME
    Resume Next
End Function

Private Function GetOptionKeyPath( _
        This As UcsDocHostHookData, _
        ByVal pOLESTRchKey As Long, _
        ByVal dw As Long) As Long
    #If This And pOLESTRchKey And dw Then '--- touch
    #End If
    'Debug.Print "DocHostUIHandler: GetOptionKeyPath "; Timer
    GetOptionKeyPath = E_NOTIMPL
End Function

Private Function GetDropTarget( _
        This As UcsDocHostHookData, _
        ByVal pDropTarget As Long, _
        ByVal ppDropTarget As Long) As Long
    #If This And pDropTarget And ppDropTarget Then '--- touch
    #End If
    'Debug.Print "DocHostUIHandler: GetDropTarget "; Timer
    GetDropTarget = E_NOTIMPL
End Function

Private Function GetExternal( _
        This As UcsDocHostHookData, _
        ppDispatch As Object) As Long
    Const FUNC_NAME     As String = "GetExternal"
    
    pvInitVbRuntime
    On Error GoTo EH
    If Not This.Sink Is Nothing Then
        Set ppDispatch = This.Sink.frGetExternal()
    End If
    'Debug.Print "DocHostUIHandler: GetExternal: "; TypeName(ppDispatch); Timer
    If ppDispatch Is Nothing Then
        GetExternal = E_NOTIMPL
    End If
    Exit Function
EH:
    PrintError FUNC_NAME
    Resume Next
End Function

Private Function TranslateUrl( _
        This As UcsDocHostHookData, _
        ByVal dwTranslate As Long, _
        ByVal pchURLIn As Long, _
        ByVal ppchURLOut As Long) As Long
    #If This And dwTranslate And pchURLIn And ppchURLOut Then '--- touch
    #End If
    'Debug.Print "DocHostUIHandler: TranslateUrl "; Timer
    TranslateUrl = E_NOTIMPL
End Function

Private Function FilterDataObject( _
        This As UcsDocHostHookData, _
        ByVal pDO As Long, _
        ByVal ppDORet As Long) As Long
    #If This And pDO And ppDORet Then '--- touch
    #End If
    'Debug.Print "DocHostUIHandler: FilterDataObject "; Timer
    FilterDataObject = E_NOTIMPL
End Function

'Private Function WTF(This As UcsDocHostHookData)
'    Debug.Print "DocHostUIHandler: WTF!@!#@#$"; Timer
'    WTF = E_NOTIMPL
'End Function

Private Sub pvInitVbRuntime()
    Dim IID_IUnknown    As VBGUID
    Dim CLSID_Dummy     As VBGUID
    Dim pUnk            As IUnknown
    
    '--- create an object
    IID_IUnknown = VBGUIDFromString("{00000000-0000-0000-C000-000000000046}")
    CLSID_Dummy = CLSIDFromProgID(LIB_NAME & ".cDummy")
    Call CoCreateInstance(CLSID_Dummy, Nothing, CLSCTX_INPROC_SERVER, IID_IUnknown, pUnk)
End Sub