; Permet de charger une page Internet depuis un String et non pas un fichier
;- IID Datasection

DataSection

  IID_IHTMLElement: ; {3050F1FF-98B5-11CF-BB82-00AA00BDCE0B}
    Data.l $3050F1FF
    Data.w $98B5, $11CF
    Data.b $BB, $82, $00, $AA, $00, $BD, $CE, $0B
 
  IID_IHTMLDocument2: ; {332C4425-26CB-11D0-B483-00C04FD90119}
    Data.l $332C4425
    Data.w $26CB, $11D0
    Data.b $B4, $83, $00, $C0, $4F, $D9, $01, $19
   
  IID_NULL: ; {00000000-0000-0000-0000-000000000000}
    Data.l $00000000
    Data.w $0000, $0000
    Data.b $00, $00, $00, $00, $00, $00, $00, $00
   
  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



;- IDispatch Implementation

Structure IDispatchVtbl
  QueryInterface.l
  AddRef.l
  Release.l
  GetTypeInfoCount.l
  GetTypeInfo.l

  GetIDsOfNames.l
  Invoke.l
EndStructure

Structure IDispatchObject
  Vtbl.l
  RefCount.l
 
  Function.l
  Gadget.l
  Window.IHTMLWindow2
  IsMouseHandler.l
EndStructure

Global NewList IDispatchObjects.IDispatchObject()

Procedure IDispatch_QueryInterface(*THIS.IDispatchObject, *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.IDispatchObject)
  *THIS\RefCount + 1
  ProcedureReturn *THIS\RefCount
EndProcedure

Procedure IDispatch_Release(*THIS.IDispatchObject)
  *THIS\RefCount - 1
  If *THIS\RefCount <= 0
    ChangeCurrentElement(IDispatchObjects(), *THIS)
    IDispatchObjects()\Window\Release()
    DeleteElement(IDispatchObjects())
    ProcedureReturn 0
  Else
    ProcedureReturn *THIS\RefCount
  EndIf
EndProcedure

Procedure IDispatch_GetTypeInfoCount(*THIS.IDispatchObject, *pctinfo.LONG)
  If *pctinfo = 0
    ProcedureReturn #E_INVALIDARG
  Else
    *pctinfo\l = 0
    ProcedureReturn #S_OK
  EndIf
EndProcedure

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

Procedure IDispatch_GetIDsOfNames(*THIS.IDispatchObject, *riid.IID, *rgszNames, cNames, lcid, *rgDispID.LONG)
  If CompareMemory(*riid, ?IID_NULL, SizeOf(IID)) = 0
    ProcedureReturn #DISP_E_UNKNOWNINTERFACE
  ElseIf *rgDispID = 0 Or cNames = 0
    ProcedureReturn #E_INVALIDARG
  Else
    While cNames > 0 ; we provide no names, so set all passed fields to DISPID_UNKNOWN (-1)
      *rgDispID\l = - 1
      *rgDispID + 4
      cNames - 1
    Wend
    ProcedureReturn #DISP_E_UNKNOWNNAME
  EndIf
EndProcedure


Procedure IDispatch_Invoke(*THIS.IDispatchObject, dispIdMember, *riid.IID, lcid, wFlags.w, *pDispParams.DISPPARAMS, *pVarResult.VARIANT, *pExcpInfo, *puArgErr)

  If CompareMemory(*riid, ?IID_NULL, SizeOf(IID)) = 0
    ProcedureReturn #DISP_E_UNKNOWNINTERFACE
  ElseIf dispIdMember <> 0 Or wFlags <> #DISPATCH_METHOD
    ProcedureReturn #DISP_E_MEMBERNOTFOUND
  ElseIf *pDispParams = 0
    ProcedureReturn #E_INVALIDARG
  ElseIf *pDispParams\cNamedArgs > 0
    ProcedureReturn #DISP_E_NONAMEDARGS
  ElseIf *pDispParams\cArgs > 0
    ProcedureReturn #DISP_E_BADPARAMCOUNT
  Else
   
    If *THIS\Window\get_event(@Event.IHTMLEventObj) = #S_OK

      If *THIS\IsMouseHandler
     
        If Event\get_button(@button) = #S_OK
          If button = 2 Or button = 3 Or button = 6 Or button = 7
            varReturn.VARIANT\vt = #VT_BOOL
            varReturn\boolVal    = #VARIANT_FALSE
            Event\put_returnValue(varReturn)
          EndIf
        EndIf
     
      Else
   
        If Event\get_srcElement(@Element.IHTMLElement) = #S_OK
       
          ; Walk up the tags until the actual link is found, as there can be
          ; an image inside the link for example
          ;
          Repeat
            Abort = 1
            If Element\get_tagName(@bstr_tag) = #S_OK And bstr_tag
              Tag$ = PeekS(bstr_tag, - 1, #PB_Unicode)
              SysFreeString_(bstr_tag)
             
              If UCase(Tag$) <> "A"
                If Element\get_parentElement(@Parent.IHTMLElement) = #S_OK
                  Element\Release()
                  Element = Parent
                  Abort = 0
                EndIf
              EndIf
            EndIf
          Until Abort
       
          If Element\get_className(@bstr_class) = #S_OK And bstr_class
            Class$ = PeekS(bstr_class, - 1, #PB_Unicode)
            SysFreeString_(bstr_class)
          EndIf
         
          If Element\get_id(@bstr_id) = #S_OK And bstr_id
            ID$ = PeekS(bstr_id, - 1, #PB_Unicode)
            SysFreeString_(bstr_id)
          EndIf
         
          If Element\get_innerText(@bstr_text) = #S_OK And bstr_text
            Text$ = PeekS(bstr_text, - 1, #PB_Unicode)
            SysFreeString_(bstr_text)
          EndIf
                   
          If Element\getAttribute("href", 0, @varResult.VARIANT) = #S_OK
            If varResult\vt = #VT_BSTR And varResult\bstrVal
              Link$ = PeekS(varResult\bstrVal, - 1, #PB_Unicode)
              SysFreeString_(varResult\bstrVal)
            EndIf
          EndIf
         
          If CallFunctionFast(*THIS\Function, *THIS\Gadget, Link$, Text$, ID$, Class$)
            varReturn.VARIANT\vt = #VT_BOOL
            varReturn\boolVal    = #VARIANT_TRUE
          Else
            varReturn.VARIANT\vt = #VT_BOOL
            varReturn\boolVal     = #VARIANT_FALSE
          EndIf
          Event\put_returnValue(varReturn)
       
        EndIf

      EndIf
      Event\Release()
    EndIf
    ProcedureReturn #S_OK
  EndIf
   
EndProcedure

Global IDispatchVtbl.IDispatchVtbl

IDispatchVtbl\QueryInterface   = @IDispatch_QueryInterface()
IDispatchVtbl\AddRef           = @IDispatch_AddRef()
IDispatchVtbl\Release          = @IDispatch_Release()
IDispatchVtbl\GetTypeInfoCount = @IDispatch_GetTypeInfoCount()
IDispatchVtbl\GetTypeInfo      = @IDispatch_GetTypeInfo()
IDispatchVtbl\GetIDsOfNames    = @IDispatch_GetIDsOfNames()
IDispatchVtbl\Invoke           = @IDispatch_Invoke()

;- Webgadget Functions

Procedure WebGadget_Open(Gadget, AddHistory)
  Shared WebGadget_Document.IHTMLDocument2
  result = 0
 
  If GetGadgetText(Gadget) = ""
    SetGadgetText(Gadget, "about:blank")
  EndIf
 
  WebGadget_Document = 0
  Browser.IWebBrowser2 = GetWindowLong_(GadgetID(Gadget), #GWL_USERDATA)
  If Browser
    If Browser\get_Document(@DocumentDispatch.IDispatch) = #S_OK
      If DocumentDispatch\QueryInterface(?IID_IHTMLDocument2, @WebGadget_Document.IHTMLDocument2) = #S_OK

;         varReplace.VARIANT\vt = #VT_BOOL
;         If AddHistory
;           varReplace\boolVal = #VARIANT_FALSE
;         Else
;           varReplace\boolVal = #VARIANT_TRUE
;         EndIf
;
;         varName.VARIANT\vt = #VT_BSTR
;         Unicode$ = Space(16)
;         PokeS(@Unicode$, "replace", -1, #PB_Unicode)
;         varName\bstrVal = SysAllocString_(@Unicode$)
;         varFeatures.VARIANT\vt = #VT_BSTR
;         varFeatures\bstrVal    = SysAllocString_(@NULLString.l)
;
;         If WebGadget_Document\open("text/html", varName, varFeatures, varReplace, @Dummy.IDispatch) = #S_OK
;           Dummy\Release()
;           result = 1
;         EndIf
;
;         SysFreeString_(varName\bstrVal)
;         SysFreeString_(varFeatures\bstrVal)


       
        varName.VARIANT\vt = #VT_BSTR
        If AddHistory
          varName\bstrVal = SysAllocString_(@NULLString.l)
        Else
          Unicode$ = Space(16)
          PokeS(@Unicode$, "replace", - 1, #PB_Unicode)
          varName\bstrVal = SysAllocString_(@Unicode$)
        EndIf
       
        varEmpty.VARIANT\vt = #VT_EMPTY
       
        If WebGadget_Document\open("text/html", varName, varEmpty, varEmpty, @Dummy.IDispatch) = #S_OK
          If Dummy
            Dummy\Release()
          EndIf
         
          result = 1
        EndIf
       
        SysFreeString_(varName\bstrVal)
       
       
      EndIf
      DocumentDispatch\Release()
    EndIf
  EndIf
 
  ProcedureReturn result
EndProcedure

Procedure WebGadget_Write(String$)
  Shared WebGadget_Document.IHTMLDocument2
 
  If WebGadget_Document
    Unicode$ = Space(Len(String$)*2 + 2)
    PokeS(@Unicode$, String$, - 1, #PB_Unicode)
    bstr_string = SysAllocString_(@Unicode$)
 
    *sfArray = SafeArrayCreateVector_(#VT_VARIANT, 0, 1)
    If *sfArray
      If SafeArrayAccessData_(*sfArray, @*varParam.VARIANT) = #S_OK
     
        *varParam\vt = #VT_BSTR
        *varParam\bstrVal = bstr_string
       
        If SafeArrayUnaccessData_(*sfArray) = #S_OK
          WebGadget_Document\write(*sfArray)
        EndIf
     
      EndIf
      SafeArrayDestroy_(*sfArray)
    EndIf
   
    SysFreeString_(bstr_string)
  EndIf
EndProcedure

Procedure WebGadget_Close()
  Shared WebGadget_Document.IHTMLDocument2
  If WebGadget_Document
    WebGadget_Document\close()
    WebGadget_Document\Release()
    WebGadget_Document = 0
  EndIf
EndProcedure


Procedure WebGadget_IsLoaded(Gadget)
  Browser.IWebBrowser2 = GetWindowLong_(GadgetID(Gadget), #GWL_USERDATA)
  If Browser
    If Browser\get_ReadyState(@state) = #S_OK
      If state = 4
        ProcedureReturn 1
      EndIf
    EndIf
  EndIf
 
  ProcedureReturn 0
EndProcedure


Procedure WebGadget_CatchLinks(Gadget, Callback)
  result = 0
 
  If GetGadgetText(Gadget) = ""
    SetGadgetText(Gadget, "about:blank")
  EndIf

  Browser.IWebBrowser2 = GetWindowLong_(GadgetID(Gadget), #GWL_USERDATA)
  If Browser
    If Browser\get_Document(@DocumentDispatch.IDispatch) = #S_OK
      If DocumentDispatch
        If DocumentDispatch\QueryInterface(?IID_IHTMLDocument2, @Document.IHTMLDocument2) = #S_OK
       
          If Document\get_links(@LinkCollection.IHTMLElementCollection) = #S_OK
            If LinkCollection\get_length(@LinkCount) = #S_OK
           
              If LinkCount = 0
                result = 1
               
              Else
                If Document\get_parentWindow(@Window.IHTMLWindow2) = #S_OK
                 
                  AddElement(IDispatchObjects())
                  IDispatchObjects()\Vtbl     = @IDispatchVtbl
                  IDispatchObjects()\RefCount = 1
                  IDispatchObjects()\Window   = Window
                  IDispatchObjects()\Gadget   = Gadget
                  IDispatchObjects()\Function = Callback
                  IDispatchObjects()\IsMouseHandler = 0
                  Dispatch.IDispatch = @IDispatchObjects()
                 
                  varDispatch.VARIANT
                  varDispatch\vt = #VT_DISPATCH
                  varDispatch\pdispVal = Dispatch
                 
                  AddElement(IDispatchObjects())
                  IDispatchObjects()\Vtbl     = @IDispatchVtbl
                  IDispatchObjects()\RefCount = 1
                  IDispatchObjects()\Window   = Window
                  IDispatchObjects()\Gadget   = Gadget
                  IDispatchObjects()\Function = Callback
                  IDispatchObjects()\IsMouseHandler = 1
                  MouseDispatch.IDispatch = @IDispatchObjects()
                 
                  varDispatch2.VARIANT
                  varDispatch2\vt = #VT_DISPATCH
                  varDispatch2\pdispVal = MouseDispatch
                 
                  For index = 0 To LinkCount - 1
                    varIndex.VARIANT\vt = #VT_I4
                    varIndex\lVal = index
                    ElementDispatch.IDispatch = 0
                   
                    If LinkCollection\item(varIndex, varIndex, @ElementDispatch.IDispatch) = #S_OK
                      If ElementDispatch ; must check this value according to the docs, as even on failure, #S_OK is returned
               
                        If ElementDispatch\QueryInterface(?IID_IHTMLElement, @Element.IHTMLElement) = #S_OK
                       
                          Element\put_onclick(varDispatch)
                          Element\put_onmouseup(varDispatch2)
                          Element\put_onmousedown(varDispatch2)
                          Element\Release()
                         
                        EndIf
                 
                        ElementDispatch\Release()
                      EndIf
                    EndIf
                  Next index
                 
                  MouseDispatch\Release()
                  If Dispatch\Release() <> 0
                    result = 1
                  EndIf
                 
                EndIf
              EndIf
           
            EndIf
            LinkCollection\Release()
          EndIf
                     
          Document\Release()
        EndIf
        DocumentDispatch\Release()
      EndIf
    EndIf
  EndIf

  ProcedureReturn result
EndProcedure



#WebGadget = 0
#WebGadget2 = 1

Procedure LinkCallback(Gadget, Link$, Text$, ID$, Class$)

  Debug "Link: " + Link$
  Debug "Text: " + Text$
  Debug ""

  ProcedureReturn 0 ; prevent link from executing
EndProcedure

If OpenWindow(0, 0, 0, 800, 600, "Test", #PB_Window_SystemMenu|#PB_Window_ScreenCentered)
  If CreateGadgetList(WindowID(0))
   
    WebGadget(#WebGadget, 0, 0, 800, 600, "")
           
    If WebGadget_Open(#WebGadget, 0)
   
      WebGadget_Write("
")
      WebGadget_Write("Chr(34)+"http://www.purebasic.com" + Chr(34)+">PureBasic.com
")
      WebGadget_Write("Chr(34)+"http://forums.purebasic.com" + Chr(34)+">Forum
")
      WebGadget_Write("")
   
      WebGadget_Close()
    EndIf
   
    WebGadget_CatchLinks(#WebGadget, @LinkCallback())

    Repeat
    Until WaitWindowEvent() = #PB_Event_CloseWindow
 
    ; If you comment out the following 2 lines - it is the other way around
    ; FreeGadget(#WebGadget)
    ; WebGadget(#WebGadget, 0, 0, 800, 600, "")
   
    If WebGadget_Open(#WebGadget, 0)
   
      WebGadget_Write("
")
      WebGadget_Write("Chr(34)+"http://www.purebasic.com" + Chr(34)+">PureBasic.com2
")
      WebGadget_Write("Chr(34)+"http://forums.purebasic.com" + Chr(34)+">Forum2
")
      WebGadget_Write("")
   
      WebGadget_Close()
    EndIf
   
    WebGadget_CatchLinks(#WebGadget, @LinkCallback())
     
    Repeat
    Until WaitWindowEvent() = #PB_Event_CloseWindow
   
  EndIf
EndIf