Skip to content

Instantly share code, notes, and snippets.

@wqweto

wqweto/cWebBrowserExtension

Created March 1, 2013 16:05
Show Gist options
  • Save wqweto/5065624 to your computer and use it in GitHub Desktop.
Save wqweto/5065624 to your computer and use it in GitHub Desktop.
Download ZIP
VB6 impl of IDocHostUIHandler for WebBrowser site
Raw
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
Raw
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment