the following code is a result of collecting snippets from this Forum and Internet. The aim is to disable JavaScript execution in WebGadget control (and printing). Most of the code for this was from this thread by hm and Justin.
Sadly, if the code is used to set the properties, the resizing does no longer work (ResizeGadget() function). If I do not use the code, resizing is fine. Any idea about, how to restore resize function?
I personally assume, that exchanging the IDispatch interfaces somehow disconnects from Freds/Purebasic interface and by this, resizing is no longer working. But I have no idea about how to prevent this because I'm really not that deep in COM and IDispatch
Code: Select all
EnableExplicit
; ------------------------------------------------------------------------------
;{ * IDispatch implementation
; -----------------------------------------------------------------------------
; - Constants
#DISPID_AMBIENT_DLCONTROL = -5512
#DLCTL_DLIMAGES = $00000010
#DLCTL_VIDEOS = $00000020
#DLCTL_BGSOUNDS = $00000040
#DLCTL_NO_SCRIPTS = $00000080
#DLCTL_NO_JAVA = $00000100
#DLCTL_NO_RUNACTIVEXCTLS = $00000200
#DLCTL_NO_DLACTIVEXCTLS = $00000400
#DLCTL_DOWNLOADONLY = $00000800
#DLCTL_NO_FRAMEDOWNLOAD = $00001000
#DLCTL_RESYNCHRONIZE = $00002000
#DLCTL_PRAGMA_NO_CACHE = $00004000
#DLCTL_NO_BEHAVIORS = $00008000
#DLCTL_NO_METACHARSET = $00010000
#DLCTL_URL_ENCODING_DISABLE_UTF8 = $00020000
#DLCTL_URL_ENCODING_ENABLE_UTF8 = $00040000
#DLCTL_FORCEOFFLINE = $10000000
#DLCTL_NO_CLIENTPULL = $20000000
#DLCTL_SILENT = $40000000
#DLCTL_OFFLINEIFNOTCONNECTED = $80000000
#DLCTL_OFFLINE = #DLCTL_OFFLINEIFNOTCONNECTED
; ------------------------------------------------------------------------------
; - Structures
Structure IDispatch_Functions
QueryInterface.i
AddRef.i
Release.i
GetTypeInfoCount.i
GetTypeInfo.i
GetIDsOfNames.i
Invoke.i
EndStructure
Structure IDispatch_Object
*IDispatch.IDispatch
RefCount.l
EndStructure
Global NewList g_IDispatch_Objects.IDispatch_Object()
Global dispatchValue.i
; ------------------------------------------------------------------------------
; - IUnknown methods
Procedure IDispatch_QueryInterface(*THIS.IDispatch_Object, *iid.IID, *Object.INTEGER)
If *Object = 0
ProcedureReturn #E_INVALIDARG
ElseIf CompareMemory(*iid, ?IID_IUnknown, SizeOf(IID)) Or CompareMemory(*iid, ?IID_IDispatch, SizeOf(IID))
*Object\i = *THIS
*THIS\RefCount + 1
ProcedureReturn #S_OK
Else
*Object\i = 0
ProcedureReturn #E_NOINTERFACE
EndIf
EndProcedure
Procedure IDispatch_AddRef(*THIS.IDispatch_Object)
*THIS\RefCount + 1
ProcedureReturn *THIS\RefCount
EndProcedure
Procedure IDispatch_Release(*THIS.IDispatch_Object)
*THIS\RefCount - 1
If *THIS\RefCount <= 0
ChangeCurrentElement(g_IDispatch_Objects(), *THIS)
DeleteElement(g_IDispatch_Objects())
ProcedureReturn 0
Else
ProcedureReturn *THIS\RefCount
EndIf
EndProcedure
; ------------------------------------------------------------------------------
; - IDispatch methods
Procedure IDispatch_GetTypeInfoCount(*THIS.IDispatch_Object, *pctinfo.INTEGER)
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure IDispatch_GetTypeInfo(*THIS.IDispatch_Object, iTInfo.l, lcid.l, *pptInfo.INTEGER)
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure IDispatch_GetIDsOfNames(*THIS.IDispatch_Object, *riid.IID, rgszNames.i, cNames.l, lcid.l, *rgDispID.INTEGER)
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure IDispatch_Invoke(*THIS.IDispatch_Object, dispIdMember.l, *riid.IID, lcid.l, wFlags.w, *pDispParams.DISPPARAMS, *pVarResult.Variant, pExcpInfo.i, puArgErr.i)
If dispIdMember = #DISPID_AMBIENT_DLCONTROL
*pVarResult\vt = #VT_I4
*pVarResult\lVal = dispatchValue.i
ProcedureReturn #S_OK
EndIf
ProcedureReturn #DISP_E_MEMBERNOTFOUND
EndProcedure
; ------------------------------------------------------------------------------
; - Data section
DataSection
_IDispatch_Functions:
Data.i @IDispatch_QueryInterface()
Data.i @IDispatch_AddRef()
Data.i @IDispatch_Release()
Data.i @IDispatch_GetTypeInfoCount()
Data.i @IDispatch_GetTypeInfo()
Data.i @IDispatch_GetIDsOfNames()
Data.i @IDispatch_Invoke()
CompilerIf Defined(IID_IUnknown, #PB_Label) = 0
IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
Data.l $00000000
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
CompilerEndIf
CompilerIf Defined(IID_IDispatch, #PB_Label) = 0
IID_IDispatch: ; {00020400-0000-0000-C000-000000000046}
Data.l $00020400
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
CompilerEndIf
EndDataSection
; ------------------------------------------------------------------------------
; - * IOleClientSite implementation
; ------------------------------------------------------------------------------
; - Structures
Structure IOleClientSite_Functions
QueryInterface.i
AddRef.i
Release.i
SaveObject.i
GetMoniker.i
GetContainer.i
ShowObject.i
OnShowWindow.i
RequestNewObjectLayout.i
EndStructure
Structure IOleClientSite_Object
*IOleClientSite.IOleClientSite
RefCount.l
EndStructure
Global NewList g_IOleClientSite_Objects.IOleClientSite_Object()
; ------------------------------------------------------------------------------
; - IUnknown methods
Procedure IOleClientSite_QueryInterface(*THIS.IOleClientSite_Object, *iid.IID, *Object.INTEGER)
If *Object = 0
ProcedureReturn #E_INVALIDARG
ElseIf CompareMemory(*iid, ?IID_IUnknown, SizeOf(IID)) Or CompareMemory(*iid, ?IID_IOleClientSite, SizeOf(IID))
*Object\i = *THIS
*THIS\RefCount + 1
ProcedureReturn #S_OK
; return pointer to IDispatch object (IDispatch is queried by the webbrowser control on its initialization)
ElseIf CompareMemory(*iid, ?IID_IDispatch, SizeOf(IID))
*Object\i = @g_IDispatch_Objects()
ProcedureReturn #S_OK
Else
*Object\i = 0
ProcedureReturn #E_NOINTERFACE
EndIf
EndProcedure
Procedure IOleClientSite_AddRef(*THIS.IOleClientSite_Object)
*THIS\RefCount + 1
ProcedureReturn *THIS\RefCount
EndProcedure
Procedure IOleClientSite_Release(*THIS.IOleClientSite_Object)
*THIS\RefCount - 1
If *THIS\RefCount <= 0
ChangeCurrentElement(g_IOleClientSite_Objects(), *THIS)
DeleteElement(g_IOleClientSite_Objects())
ProcedureReturn 0
Else
ProcedureReturn *THIS\RefCount
EndIf
EndProcedure
; ------------------------------------------------------------------------------
; - IOleClientSite methods
Procedure IOleClientSite_SaveObject(*THIS.IOleClientSite_Object)
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure IOleClientSite_GetMoniker(*THIS.IOleClientSite_Object, dwAssign.l, dwWhichMoniker.l, mk.i )
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure IOleClientSite_GetContainer(*THIS.IOleClientSite_Object, container.i)
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure IOleClientSite_ShowObject(*THIS.IOleClientSite_Object)
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure IOleClientSite_OnShowWindow(*THIS.IOleClientSite_Object, fShow.l)
ProcedureReturn #E_NOTIMPL
EndProcedure
Procedure IOleClientSite_RequestNewObjectLayout(*THIS.IOleClientSite_Object)
ProcedureReturn #E_NOTIMPL
EndProcedure
; ------------------------------------------------------------------------------
; - Data section
DataSection
_IOleClientSite_Functions:
Data.i @IOleClientSite_QueryInterface()
Data.i @IOleClientSite_AddRef()
Data.i @IOleClientSite_Release()
Data.i @IOleClientSite_SaveObject()
Data.i @IOleClientSite_GetMoniker()
Data.i @IOleClientSite_GetContainer()
Data.i @IOleClientSite_ShowObject()
Data.i @IOleClientSite_OnShowWindow()
Data.i @IOleClientSite_RequestNewObjectLayout()
; IOleClientSite
; {00000118-0000-0000-C000-000000000046}
IID_IOleClientSite:
Data.l $00000118
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
; IOleObject
; {00000112-0000-0000-C000-000000000046}
IID_IOleObject:
Data.l $00000112
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
; IOleControl
; {B196B288-BAB4-101A-B69C-00AA00341D07}
IID_IOleControl:
Data.l $B196B288
Data.w $BAB4, $101A
Data.b $B6, $9C, $00, $AA, $00, $34, $1D, $07
EndDataSection
;}-----------------------------------------------------------------------------
; --------------------------------------
;{ Constants for the ExecWB Method
; -------------------------------------
#OLECMDID_OPEN = 1
#OLECMDID_NEW = 2
#OLECMDID_SAVE = 3
#OLECMDID_SAVEAS = 4
#OLECMDID_SAVECOPYAS = 5
#OLECMDID_PRINT = 6
#OLECMDID_PRINTPREVIEW = 7
#OLECMDID_PAGESETUP = 8
#OLECMDID_SPELL = 9
#OLECMDID_PROPERTIES = 10
#OLECMDID_CUT = 11
#OLECMDID_COPY = 12
#OLECMDID_PASTE = 13
#OLECMDID_PASTESPECIAL = 14
#OLECMDID_UNDO = 15
#OLECMDID_REDO = 16
#OLECMDID_SELECTALL = 17
#OLECMDID_CLEARSELECTION = 18
#OLECMDID_ZOOM = 19
#OLECMDID_GETZOOMRANGE = 20
#OLECMDID_UPDATECOMMANDS = 21
#OLECMDID_REFRESH = 22
#OLECMDID_STOP = 23
#OLECMDID_HIDETOOLBARS = 24
#OLECMDID_SETPROGRESSMAX = 25
#OLECMDID_SETPROGRESSPOS = 26
#OLECMDID_SETPROGRESSTEXT = 27
#OLECMDID_SETTITLE = 28
#OLECMDID_SETDOWNLOADSTATE = 29
#OLECMDID_STOPDOWNLOAD = 30
#OLECMDID_ONTOOLBARACTIVATED = 31
#OLECMDID_FIND = 32
#OLECMDID_DELETE = 33
#OLECMDID_HTTPEQUIV = 34
#OLECMDID_HTTPEQUIV_DONE = 35
#OLECMDID_ENABLE_INTERACTION = 36
#OLECMDID_ONUNLOAD = 37
#OLECMDID_PROPERTYBAG2 = 38
#OLECMDID_PREREFRESH = 39
#OLECMDID_SHOWSCRIPTERROR = 40
#OLECMDID_SHOWMESSAGE = 41
#OLECMDID_SHOWFIND = 42
#OLECMDID_SHOWPAGESETUP = 43
#OLECMDID_SHOWPRINT = 44
#OLECMDID_CLOSE = 45
#OLECMDID_ALLOWUILESSSAVEAS = 46
#OLECMDID_DONTDOWNLOADCSS = 47
#OLECMDID_UPDATEPAGESTATUS = 48
#OLECMDID_PRINT2 = 49
#OLECMDID_PRINTPREVIEW2 = 50
#OLECMDID_SETPRINTTEMPLATE = 51
#OLECMDID_GETPRINTTEMPLATE = 52
#OLECMDID_PAGEACTIONBLOCKED = 55
#OLECMDID_PAGEACTIONUIQUERY = 56
#OLECMDID_FOCUSVIEWCONTROLS = 57
#OLECMDID_FOCUSVIEWCONTROLSQUERY = 58
#OLECMDEXECOPT_DODEFAULT = 0
#OLECMDEXECOPT_PROMPTUSER = 1
#OLECMDEXECOPT_DONTPROMPTUSER = 2
#OLECMDEXECOPT_SHOWHELP = 3
;}
Procedure PutDispatchValueToWebgadget(WebgadgetID.i)
Protected oleObject.IOleObject
Protected oleControl.IOleControl
Protected myBrowser.IWebBrowser2 = GetWindowLong_(GadgetID(WebgadgetID.i), #GWL_USERDATA)
If myBrowser\QueryInterface(?IID_IOleObject, @oleObject) = #S_OK
; new IDispatch object
AddElement(g_IDispatch_Objects())
g_IDispatch_Objects()\IDispatch = ?_IDispatch_Functions
; new IOleClientSite object
AddElement(g_IOleClientSite_Objects())
g_IOleClientSite_Objects()\IOleClientSite = ?_IOleClientSite_Functions
; tell the webbrowser client about our IOleClientSite object
If oleObject\SetClientSite(@g_IOleClientSite_Objects()) = #S_OK
If myBrowser\QueryInterface(?IID_IOleControl, @oleControl) = #S_OK
; tell the webbrowser control that Ambient Properties have changed so it queries
; our IOleClientSite object for the IDispatch interface and calls IDispatch::Invoke
; with DISPID_AMBIENT_DLCONTROL
oleControl\OnAmbientPropertyChange(#DISPID_AMBIENT_DLCONTROL)
oleControl\Release()
Else
Debug "Failed for myBrowser\QueryInterface"
EndIf
Else
Debug "Failed for oleObject\SetClientSite"
EndIf
oleObject\Release()
EndIf
EndProcedure
Procedure WebGadget_EnableJS(WebgadgetID.i)
dispatchValue.i = #DLCTL_DLIMAGES | #DLCTL_VIDEOS | #DLCTL_BGSOUNDS ; do not disable anything here
; https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/platform-apis/aa770041(v=vs.85)
PutDispatchValueToWebgadget(WebgadgetID.i)
EndProcedure
Procedure WebGadget_DisableJS(WebgadgetID.i)
dispatchValue.i = #DLCTL_NO_JAVA | #DLCTL_NO_SCRIPTS |
#DLCTL_NO_DLACTIVEXCTLS | #DLCTL_NO_RUNACTIVEXCTLS |
#DLCTL_NO_FRAMEDOWNLOAD | #DLCTL_SILENT | #DLCTL_DLIMAGES
; https://docs.microsoft.com/en-us/previous-versions/windows/internet-explorer/ie-developer/platform-apis/aa770041(v=vs.85)
PutDispatchValueToWebgadget(WebgadgetID.i)
EndProcedure
Procedure SetFeature_Browser_Emulation()
Protected lpValueName.s,lpData.l,phkResult,lpsdata.s,lpdwDisposition.i
lpValueName.s = GetFilePart(ProgramFilename())
lpData = 11001 ; Webpages containing standards-based !DOCTYPE directives are displayed in IE11 Standards mode.
If RegCreateKeyEx_(#HKEY_CURRENT_USER,
"SOFTWARE\Microsoft\Internet Explorer\Main\FeatureControl\FEATURE_BROWSER_EMULATION",
0, #Null, #REG_OPTION_VOLATILE, #KEY_ALL_ACCESS, #Null,
@phkResult, @lpdwDisposition) = #ERROR_SUCCESS
RegSetValueEx_(phkResult, lpValueName, 0, #REG_DWORD, @lpData, SizeOf(LONG))
RegCloseKey_(phkResult)
EndIf
EndProcedure
Procedure WebGadget_SetNavigationCallback(WebgadgetID.i, *CallBackFunction)
; Somehow works by default on Windows
SetGadgetAttribute(WebgadgetID.i, #PB_Web_NavigationCallback,
*CallBackFunction)
EndProcedure
Procedure WebGadget_Print(WebgadgetID.i)
Protected WebObject.IWebBrowser2 = GetWindowLong_(GadgetID(WebgadgetID.i), #GWL_USERDATA)
Protected IsReady.i
Protected timeout.i = ElapsedMilliseconds() + 8000 ; 8 sec timeout
Repeat
WebObject\get_ReadyState(@IsReady.i)
Delay(1)
While WindowEvent(): Wend
Until IsReady.i = 4 Or ElapsedMilliseconds() > timeout.i ; 4 = READYSTATE_COMPLETE
;This prompts the user with the print properties window first
WebObject\ExecWB(#OLECMDID_PRINT, #OLECMDEXECOPT_PROMPTUSER, 0, 0)
EndProcedure
SetFeature_Browser_Emulation(); activate browser emulation mode to IE11 (always!)
CompilerIf #PB_Compiler_IsMainFile
; TEST CODE
If OpenWindow(0, 0, 0, 600, 300, "WebGadget test window",
#PB_Window_SystemMenu | #PB_Window_ScreenCentered | #PB_Window_SizeGadget)
WebGadget(0, 0, 0, 600, 300, "about:blank")
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
WebGadget_DisableJS(0) ; if not called, resizing works!
; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SetGadgetText(0, "https://www.purebasic.com/")
Repeat
Define wEvt.i = WaitWindowEvent()
If wEvt.i = #PB_Event_SizeWindow
ResizeGadget(0, #PB_Ignore, #PB_Ignore,
WindowWidth(0, #PB_Window_InnerCoordinate),
WindowHeight(0, #PB_Window_InnerCoordinate))
EndIf
Until wEvt.i = #PB_Event_CloseWindow
EndIf
CompilerEndIf