WebGadget: Directly insert code and catch link clicks.

Beach · Post by **Beach** » Sat Apr 22, 2006 4:06 pm

freak wrote:IID is just another name for the GUID structure. just write
Code: Select all
Structure IID Extends GUID: EndStructure

Thanks Freak... The structure is found but now I'm getting this compiler error: "Error: Label not found (iid_iunknown)"

BTW: I'm using the test code you posted on the first post.

Flype · Post by **Flype** » Sat Apr 22, 2006 6:17 pm

please retry download the link i provided

the last archive was 0 Kb sized.

Beach · Post by **Beach** » Sat Apr 22, 2006 6:44 pm

Flype wrote:please retry download the link i provided the last archive was 0 Kb sized.

Either something is going on with PureStorage or I am missing something completely here. The files in the archive do not look any different than the files in the first archive posted.

Flype · Post by **Flype** » Sat Apr 22, 2006 7:42 pm

i'm sorry - very strange - i think i must good ok now http://www.penguinbyte.com/apps/pbwebst ... _pb394.zip

Beach · Post by **Beach** » Sat Apr 22, 2006 8:25 pm

Flype wrote:i'm sorry - very strange - i think i must good ok now http://www.penguinbyte.com/apps/pbwebst ... _pb394.zip

Sorry to have caused you trouble. I think this was a FireFox issue. I downloaded the file with FireFox above and it did not look any different again. Then I tried the link with IE and the files inside work perfectly with the test. Man, that is the first time FireFox has let me down.

Again, sorry to trouble you.

Flype · Post by **Flype** » Sat Apr 22, 2006 8:42 pm

no problem man

benny · Post by **benny** » Thu Apr 27, 2006 10:19 pm

@fr34k:

First of all (as I said on irc) - thanks for sharing such wonderful code. Today
I found the time to play around with it ...

Unfortunately I have some problems with setting the callback a second time.
Everytime the callback is not called (if you do not press on a link) the
program exists with an INVALID MEMORY ACCESS.

To reproduce the error do the following:

(1) Press the first time on the WINDOW_CLOSE button in the title bar
(2) Press the second time on the WINDOW_CLOSE button

To avoid the error :

(1) Just press in at least one case on a link

Complete code (PB4.11Beta). Any help/hint is highly appreciated

Code: Select all

;- 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("<html><body><center><br>")
      WebGadget_Write("<a href="+Chr(34)+"http://www.purebasic.com"+Chr(34)+">PureBasic.com</a><br>")
      WebGadget_Write("<a href="+Chr(34)+"http://forums.purebasic.com"+Chr(34)+">Forum</a><br>")     
      WebGadget_Write("</center></body></html>")
   
      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("<html><body><center><br>")
      WebGadget_Write("<a href="+Chr(34)+"http://www.purebasic.com"+Chr(34)+">PureBasic.com2</a><br>")
      WebGadget_Write("<a href="+Chr(34)+"http://forums.purebasic.com"+Chr(34)+">Forum2</a><br>")       
      WebGadget_Write("</center></body></html>")
   
      WebGadget_Close()
    EndIf
   
    WebGadget_CatchLinks(#WebGadget, @LinkCallback())    
      
    Repeat
    Until WaitWindowEvent() = #PB_Event_CloseWindow   
   
  EndIf
EndIf

troy · Post by **troy** » Sat May 20, 2006 7:05 pm

Check this example. I got "Invalid Memory Access" error on SysFreeString_(bstr_string) in WebGadget_Write(String$) function. Any ideas why and how to fix it?

Code: Select all

XIncludeFile "WebGadgetExtras.pb"

str1$ = ""

For i=0 To 300
  str1$ = str1$ + "longlonglonglonglonglonglonglonglonglonglonglonglonglonglong string here"
Next

Debug Len(str1$)

If OpenWindow(0, 400, 400, 500, 300, "Test",  #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_ScreenCentered)
    If CreateGadgetList(WindowID(0))
      WebGadget(1,0,0,WindowWidth(0),WindowHeight(0)-sbHeight,"")

      If WebGadget_Open(1,0)
      
        WebGadget_Write(str1$)
        WebGadget_Close()
      EndIf      

    EndIf

EndIf

Repeat 
Event = WaitWindowEvent() 

Select Event 
Case #PB_Event_Gadget 
Select EventGadget() 
;Case 0 
EndSelect 
EndSelect 
Until Event = #PB_Event_CloseWindow

PHP · Post by **PHP** » Sat Jul 29, 2006 5:33 pm

Why don't work the functions in threads???!!!

Joakim Christiansen · Post by **Joakim Christiansen** » Wed Aug 16, 2006 2:22 am

I use some functions from this in my Internet TV thing and for one user using Windows 2000 SP4 it crashed on this line:

Code: Select all

If DocumentDispatch\QueryInterface(?IID_IHTMLDocument2, @WebGadget_Document.IHTMLDocument2) = #S_OK

I guess it is what we call a invalid memory access!
Anyone know why this might happen on some computers?

Dare · Post by **Dare** » Mon Aug 21, 2006 3:07 am

I am getting the same crash with invalid memory access.

Code: Select all

If DocumentDispatch\QueryInterface(?IID_IHTMLDocument2, @WebGadget_Document.IHTMLDocument2) = #S_OK

Windows XP pro, just using the include and the example originally posted.

Don't have a clue as to how to fix it.

White Eagle · Post by **White Eagle** » Sun Nov 26, 2006 9:04 am

Couple of questions:

1. Does anybody know if this works when IE 7 is installed?
2. Does anybody know if this works problem free on Vista?

netmaestro · Post by **netmaestro** » Sun Nov 26, 2006 9:08 am

I probably shouldn't post because I'm not sure but I saw a couple posts earlier on the forum that said the webgadget has some problems with IE7. Try a search, it might turn them up.

White Eagle · Post by **White Eagle** » Sun Nov 26, 2006 9:20 am

netmaestro · Post by **netmaestro** » Sun Nov 26, 2006 9:31 am

Well - you know Fred, if there is a problem he won't leave it that way for long.

PureBasic Forums - English

WebGadget: Directly insert code and catch link clicks.

SysFreeString_ problems