Das ist äußerst seltsam.
Code: Alles auswählen
;- 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
Global DocumentDispatch.IDispatch
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
CallDebugger
Browser.IWebBrowser2 = GetWindowLong_(GadgetID(Gadget), #GWL_USERDATA)
If Browser
If Browser\get_Document(@DocumentDispatch.IDispatch) = #S_OK
Debug DocumentDispatch
;If DocumentDispatch
Debug DocumentDispatch\QueryInterface(?IID_IHTMLDocument2, @Document.IHTMLDocument2)
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
Den auch bei deinem geposteten Beispiel erzeugt WebGadget_Open() in Zeile 233 einen "Invalid memory access".
.