[Windows] WebGadget download control: block scripts,java,img

[hm]

After reading MSDN and many examples on the web I am finally ready to present an example of WebGadget customization.

This example shows how you can block images, videos, background sounds, script execution, java, activex, ... in a WebGadget. Look at MSDN for the whole list.

It is based heavily on the code of soerenkj & nico's IDispatch implementation and the UI-lessParser, a Delphi example showing the use of MSHTML as a HTML parser without user interface (based on WalkAll example from Windows SDK), some code generated by visual designer and some datasection lines of srod's COMate.

It involves iplementing two interfaces: IDispatch and IOleClientSite.
The new IOleClientSite interface is registered with the WebGadget by querying its IOleObject interface and calling the SetClientSite method.
Then we query the WebGadgets IOleControl interface and call the OnAmbientPropertyChange method. This triggers the WebGadget to query our IOleClientSite for IDispatch interface and call Invoke method of our IDispatch implementation. This is where we can control the browsers behavior just by setting the referenced pVarResult accordingly.
Please read MSDN or the Delphi example website for more information on internal workings and for a description of the flags you can use.

There are probably some errors like missing de-initialization => memory leaks... so please report errors and enhancements.

tested on XP media center edition, IE7

you can have the same effect by implementing IDispatch but without implementing IOleClientSite. the methods being called are IOleClientSite::QueryInterface and IDispatch::Invoke.
you could give IDispatch as param to IOleObject::SetClientSite => QueryInterface method of IDispatch is called and returns ref to self => Invoke method of IDispatch is called to ask for Download Control flags.

Code: Select all

;------------------------------------------------------------------------------
;- * 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.l 
  AddRef.l 
  Release.l 
  GetTypeInfoCount.l 
  GetTypeInfo.l 
  GetIDsOfNames.l 
  Invoke.l 
EndStructure 

Structure IDispatch_Object
  *IDispatch.IDispatch
  RefCount.l
EndStructure

Global NewList g_IDispatch_Objects.IDispatch_Object()


;------------------------------------------------------------------------------
;- IUnknown methods

Procedure IDispatch_QueryInterface(*THIS.IDispatch_Object, *iid.IID, *Object.Long)
  If *Object = 0
    ProcedureReturn #E_INVALIDARG
  ElseIf CompareMemory(*iid, ?IID_IUnknown, SizeOf(IID)) Or CompareMemory(*iid, ?IID_IDispatch, SizeOf(IID))
    *Object\l = *THIS
    *THIS\RefCount + 1
    ProcedureReturn #S_OK  
  Else
    *Object\l = 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.Long)
  ProcedureReturn #E_NOTIMPL
EndProcedure


Procedure IDispatch_GetTypeInfo(*THIS.IDispatch_Object, iTInfo, lcid, *pptInfo)
  ProcedureReturn #E_NOTIMPL
EndProcedure


Procedure IDispatch_GetIDsOfNames(*THIS.IDispatch_Object, *riid.IID, *rgszNames, cNames, lcid, *rgDispID.Long)
  ProcedureReturn #E_NOTIMPL
EndProcedure


Procedure IDispatch_Invoke(*THIS.IDispatch_Object, dispIdMember, *riid.IID, lcid, wFlags.w, *pDispParams.DISPPARAMS, *pVarResult.Variant, *pExcpInfo, *puArgErr)
  If dispIdMember = #DISPID_AMBIENT_DLCONTROL
    *pVarResult\vt = #VT_I4
    *pVarResult\lVal = #DLCTL_NO_JAVA | #DLCTL_NO_DLACTIVEXCTLS | #DLCTL_NO_RUNACTIVEXCTLS | #DLCTL_SILENT
    Debug "**** IDispatch::Invoke() #DISPID_AMBIENT_DLCONTROL"
    Debug *pVarResult\lVal
    Debug "****"
    ProcedureReturn #S_OK
  EndIf 
  ProcedureReturn #DISP_E_MEMBERNOTFOUND
EndProcedure

;------------------------------------------------------------------------------
;- Data section

DataSection 
  _IDispatch_Functions: 
  Data.l @IDispatch_QueryInterface()
  Data.l @IDispatch_AddRef()
  Data.l @IDispatch_Release()
  Data.l @IDispatch_GetTypeInfoCount() 
  Data.l @IDispatch_GetTypeInfo()
  Data.l @IDispatch_GetIDsOfNames()
  Data.l @IDispatch_Invoke() 
  
  IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
  Data.l $00000000
  Data.w $0000, $0000
  Data.b $C0, $00, $00, $00, $00, $00, $00, $46
  
  IID_IDispatch: ; {00020400-0000-0000-C000-000000000046}
  Data.l $00020400
  Data.w $0000, $0000
  Data.b $C0, $00, $00, $00, $00, $00, $00, $46
  
EndDataSection  






;------------------------------------------------------------------------------
;- * IOleClientSite implementation

;------------------------------------------------------------------------------
;- Structures
Structure IOleClientSite_Functions
  QueryInterface.l
  AddRef.l
  Release.l
  SaveObject.l
  GetMoniker.l
  GetContainer.l
  ShowObject.l
  OnShowWindow.l
  RequestNewObjectLayout.l
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.Long)
  If *Object = 0
    ProcedureReturn #E_INVALIDARG
  ElseIf CompareMemory(*iid, ?IID_IUnknown, SizeOf(IID)) Or CompareMemory(*iid, ?IID_IOleClientSite, SizeOf(IID))
    *Object\l = *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\l = @g_IDispatch_Objects()
    ProcedureReturn #S_OK
  Else
    *Object\l = 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.IMoniker )
  ProcedureReturn #E_NOTIMPL
EndProcedure

Procedure IOleClientSite_GetContainer(*THIS.IOleClientSite_Object, container.IOleContainer)
  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.l @IOleClientSite_QueryInterface()
  Data.l @IOleClientSite_AddRef()
  Data.l @IOleClientSite_Release()
  Data.l @IOleClientSite_SaveObject()
  Data.l @IOleClientSite_GetMoniker()
  Data.l @IOleClientSite_GetContainer()
  Data.l @IOleClientSite_ShowObject()
  Data.l @IOleClientSite_OnShowWindow()
  Data.l @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    
  
EndDataSection  









;------------------------------------------------------------------------------
;- * Main program

Enumeration
  #Window_Main
EndEnumeration

Enumeration
  #Button_Start
  #Web_0
EndEnumeration

If OpenWindow(#Window_Main, 302, 15, 600, 320, "pb-klicker",  #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_TitleBar )
  ButtonGadget(#Button_Start, 20, 260, 110, 40, "Start")
  
  WebGadget(#Web_0, 20, 20, 560, 215, "about:blank")
  ; WebGadget initialization
  Global myBrowser.IWebBrowser2 = GetWindowLong_(GadgetID(#Web_0), #GWL_USERDATA)
  If myBrowser\QueryInterface(?IID_IOleObject, @oleObject.IOleObject) = #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.IOleControl) = #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()
      EndIf
    EndIf
    oleObject\Release()
  EndIf
EndIf


Repeat
  Event = WaitWindowEvent()
  WindowID = EventWindow()
  GadgetID = EventGadget()
  EventType = EventType()
  
  If Event = #PB_Event_Gadget
    If GadgetID = #Button_Start
      SetGadgetText(#Web_0, "http://www.purebasic.com/")
      
    ElseIf GadgetID = #Web_0
      
    EndIf
  EndIf
Until Event = #PB_Event_CloseWindow ; End of the event loop

End


DataSection  
  ; 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

please report errors and enhancements.

[Dude]

Thank you for this code. I know I'll use it one day.

[Justin]

I fixed the code for 32/64 bit and pb last versions, added enableexplicit.
Very good example, thanks to the author.

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()


;------------------------------------------------------------------------------
;- 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 = #DLCTL_NO_JAVA | #DLCTL_NO_DLACTIVEXCTLS | #DLCTL_NO_RUNACTIVEXCTLS | #DLCTL_SILENT
    Debug "**** IDispatch::Invoke() #DISPID_AMBIENT_DLCONTROL"
    Debug *pVarResult\lVal
    Debug "****"
    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() 
  
  IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
  Data.l $00000000
  Data.w $0000, $0000
  Data.b $C0, $00, $00, $00, $00, $00, $00, $46
  
  IID_IDispatch: ; {00020400-0000-0000-C000-000000000046}
  Data.l $00020400
  Data.w $0000, $0000
  Data.b $C0, $00, $00, $00, $00, $00, $00, $46
  
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    
  
EndDataSection  

Procedure ResizeWebgadget(gd.i, x.l, y.l, width.l, height.l, redraw.b = #True)
	Define.i hwGd
	Define.IWebBrowser2 wb
	Define.IOleObject oObj
	Define.IOleInPlaceObject ipObj
	Define.RECT rc
	
	hwGd = GadgetID(gd)
	wb = GetWindowLongPtr_(hwGd, #GWLP_USERDATA)
	If wb
	  If wb\QueryInterface(?IID_IOleObject, @oObj) = #S_OK
	  	If oObj\QueryInterface(?IID_IOleInPlaceObject, @ipObj) = #S_OK
	  		;Use MoveWindow() or ResizeGadget()
				MoveWindow_(hwGd, x, y, width, height, redraw)
				;ResizeGadget(gd, x, y, width, height) maybe this calls SetObjectRects() again ?
				GetClientRect_(hwGd, @rc)
				ipObj\SetObjectRects(@rc, @rc)
				ipObj\Release()
			EndIf 
			oObj\Release()
	  EndIf 
	EndIf 
EndProcedure









;------------------------------------------------------------------------------
;- * Main program

Enumeration
  #Window_Main
EndEnumeration

Enumeration
  #Button_Start
  #Web_0
EndEnumeration

Define.IOleObject oleObject
Define.IOleControl oleControl
Define.i Event, WindowID, GadgetID, EventType

If OpenWindow(#Window_Main, 302, 15, 600, 320, "pb-klicker",  #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_TitleBar )
  ButtonGadget(#Button_Start, 20, 260, 110, 40, "Start")
  
  WebGadget(#Web_0, 20, 20, 560, 215, "about:blank")
  ; WebGadget initialization
  Global myBrowser.IWebBrowser2 = GetWindowLongPtr_(GadgetID(#Web_0), #GWLP_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()
      EndIf
    EndIf
    oleObject\Release()
  EndIf
EndIf


Repeat
  Event = WaitWindowEvent()
  WindowID = EventWindow()
  GadgetID = EventGadget()
  EventType = EventType()
  
  If Event = #PB_Event_Gadget
    If GadgetID = #Button_Start
      SetGadgetText(#Web_0, "http://www.purebasic.com/")
      
    ElseIf GadgetID = #Web_0
      
    EndIf
  EndIf
Until Event = #PB_Event_CloseWindow ; End of the event loop

End


DataSection  
  ; 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    

  ;("00000113-0000-0000-C000-000000000046")
  IID_IOleInPlaceObject:
  Data.l $00000113
  Data.w $0000, $0000
  Data.b $C0, $00, $00, $00, $00, $00, $00, $46 
  
EndDataSection

[Justin]

Added ResizeWebgadget().

[Kwai chang caine]

Works here on W10 x64 / v5.62 x86
Thanks for sharing

[ricardo]

I fixed the code for 32/64 bit and pb last versions, added enableexplicit.
Very good example, thanks to the author.

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()


;------------------------------------------------------------------------------
;- 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 = #DLCTL_NO_JAVA | #DLCTL_NO_DLACTIVEXCTLS | #DLCTL_NO_RUNACTIVEXCTLS | #DLCTL_SILENT
    Debug "**** IDispatch::Invoke() #DISPID_AMBIENT_DLCONTROL"
    Debug *pVarResult\lVal
    Debug "****"
    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() 
  
  IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
  Data.l $00000000
  Data.w $0000, $0000
  Data.b $C0, $00, $00, $00, $00, $00, $00, $46
  
  IID_IDispatch: ; {00020400-0000-0000-C000-000000000046}
  Data.l $00020400
  Data.w $0000, $0000
  Data.b $C0, $00, $00, $00, $00, $00, $00, $46
  
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    
  
EndDataSection  

Procedure ResizeWebgadget(gd.i, x.l, y.l, width.l, height.l, redraw.b = #True)
	Define.i hwGd
	Define.IWebBrowser2 wb
	Define.IOleObject oObj
	Define.IOleInPlaceObject ipObj
	Define.RECT rc
	
	hwGd = GadgetID(gd)
	wb = GetWindowLongPtr_(hwGd, #GWLP_USERDATA)
	If wb
	  If wb\QueryInterface(?IID_IOleObject, @oObj) = #S_OK
	  	If oObj\QueryInterface(?IID_IOleInPlaceObject, @ipObj) = #S_OK
	  		;Use MoveWindow() or ResizeGadget()
				MoveWindow_(hwGd, x, y, width, height, redraw)
				;ResizeGadget(gd, x, y, width, height) maybe this calls SetObjectRects() again ?
				GetClientRect_(hwGd, @rc)
				ipObj\SetObjectRects(@rc, @rc)
				ipObj\Release()
			EndIf 
			oObj\Release()
	  EndIf 
	EndIf 
EndProcedure









;------------------------------------------------------------------------------
;- * Main program

Enumeration
  #Window_Main
EndEnumeration

Enumeration
  #Button_Start
  #Web_0
EndEnumeration

Define.IOleObject oleObject
Define.IOleControl oleControl
Define.i Event, WindowID, GadgetID, EventType

If OpenWindow(#Window_Main, 302, 15, 600, 320, "pb-klicker",  #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_TitleBar )
  ButtonGadget(#Button_Start, 20, 260, 110, 40, "Start")
  
  WebGadget(#Web_0, 20, 20, 560, 215, "about:blank")
  ; WebGadget initialization
  Global myBrowser.IWebBrowser2 = GetWindowLongPtr_(GadgetID(#Web_0), #GWLP_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()
      EndIf
    EndIf
    oleObject\Release()
  EndIf
EndIf


Repeat
  Event = WaitWindowEvent()
  WindowID = EventWindow()
  GadgetID = EventGadget()
  EventType = EventType()
  
  If Event = #PB_Event_Gadget
    If GadgetID = #Button_Start
      SetGadgetText(#Web_0, "http://www.purebasic.com/")
      
    ElseIf GadgetID = #Web_0
      
    EndIf
  EndIf
Until Event = #PB_Event_CloseWindow ; End of the event loop

End


DataSection  
  ; 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    

  ;("00000113-0000-0000-C000-000000000046")
  IID_IOleInPlaceObject:
  Data.l $00000113
  Data.w $0000, $0000
  Data.b $C0, $00, $00, $00, $00, $00, $00, $46 
  
EndDataSection

And if i only want to stop showing images but want to let run javascript?

[Justin]

In IDispatch_Invoke() set:

*pVarResult\lVal = #DLCTL_SILENT

images are displayed if you set #DLCTL_DLIMAGES, do a search for the DLCTL_ constants they are documented.

[ricardo]

In IDispatch_Invoke() set:

*pVarResult\lVal = #DLCTL_SILENT

images are displayed if you set #DLCTL_DLIMAGES, do a search for the DLCTL_ constants they are documented.

Hi,

Thanks for your answer.

What does #DISPID_AMBIENT_DLCONTROL = -5512 means?

I want be able to play MUTED videos in Youtube but don't download all the images (thumbnails of the videos) to navigate faster.

[Justin]

maybe

*pVarResult\lVal = #DLCTL_VIDEOS | #DLCTL_SILENT

i haven't test it, those are windows constants defined in some header.
COM is very complex and difficult to explain, try to find some info on msdn or google. this is a very good example.
this is becoming a black art, most of the links are dead, all the msdn kb links have disapeard, among the sdk samples about this, in fact the whole msdn is screwed up these days. microsoft is shifting people towards .net and other crap

[ricardo]

maybe

*pVarResult\lVal = #DLCTL_VIDEOS | #DLCTL_SILENT

i haven't test it, those are windows constants defined in some header.
COM is very complex and difficult to explain, try to find some info on msdn or google. this is a very good example.
this is becoming a black art, most of the links are dead, all the msdn kb links have disapeard, among the sdk samples about this, in fact the whole msdn is screwed up these days. microsoft is shifting people towards .net and other crap

Thanks, i made a fast test and without testing more deeply, just like a first view, it looks like the *pVarResult\lVal = #DLCTL_VIDEOS | #DLCTL_SILENT did the trick.

Thank You !!!