From 2005 the clsObjectExtender was a fine class for late binding objects with events. But how we can use if we have our own object which raise events and we want that object to be present on a VBScript script?
The problem with the old clsObjectExtender was the use of Variants VT_VARIANT + VT_REF. So this new version refresh the old code to do the job properly.
Also I test the code for leaks, using a 100000 loop.
The program is in main() in a module. The events comes from an array of clsObjectExtender, in a module (so we can't use WithEvents), and we attach ShinkEvent, a class which have events and some subs as methods. So we place some SinkEvent objects, in a VBScript object, using names like Debug and Sum. At the execution of the VbScript script the code fire events from ShinkEvents objects and through clsObjectExtender (in an array), they call the same sub, in Module1.bas: EventRaised, with for parameters:
oTarget is the object (ShinkEvent) who fires the event
ID is a number which we give to clsObjectExtender for Identificarion in this sub.
strName is the event name
params() is a Variant type array to hold parameters. Although is a Variant type array, if the parameter isn't variant we have to keep the same type. But if the parameter is a variant type then we can change type. From the test the VBScript for numbers use automatic adjustment, so if we have variable j with a value 1 then this have a sub-type Integer. So if we get that by reference there are a chance to alter the type, in our code, and then return the new type. That can be done with this version. Also we can pass by reference Variant Arrays.
Code:
Public Sub EventRaised(oTarget As Object, ByVal ID As Long, ByVal strName As String, params() As Variant)
On Error Resume Next
Dim i As Long
Dim Resp()
If ID = 1001 Then
If strName = "GetData" Then
Resp() = oTarget.GetData()
here:
For i = LBound(Resp) To UBound(Resp) - 1
If pr Then Debug.Print Resp(i),
Next i
If i = UBound(Resp) Then
If pr Then Debug.Print Resp(i)
End If
ElseIf strName = "GetString" Then
params(1) = "1234"
ElseIf strName = "GetNumber" Then
params(1) = params(1) * params(1)
ElseIf strName = "GetArray" Then
sum = sum + params(1)(2)
params(1)(0) = sum
Resp() = params(1)
GoTo here
ElseIf strName = "GetCalc" Then
If params(1) = "multiply" Then
params(2) = params(3) * params(4)
End If
Else
GoTo error1
End If
ElseIf ID = 1002 Then
If strName = "GetNumber" Then
params(1) = sum
Else
GoTo error1
End If
ElseIf ID = 1003 Then
If strName = "GetVBString" Then
params(1) = params(1) + "1234"
ElseIf strName = "GetString" Then
params(1) = params(1) + "123456"
ElseIf strName = "GetDecimal" Then
params(1) = params(1) + CDec("50000000000000000000000000")
ElseIf strName = "GetData" Then
Resp() = oTarget.GetData()
GoTo here
ElseIf strName = "GetCurrency" Then
params(1) = params(1) + CCur("9999999999999")
Else
GoTo error1
End If
Else
If pr Then Debug.Print "ID Event " & ID & " has no code for Events"
End If
Exit Sub
error1:
If pr Then Debug.Print "Event " + strName + " has no code"
End Sub
In the Module1 there are some TestX subs where X=1 to 5. There are two globals, pr as boolean to switch the debug.print on or off, so for a lengthy run we use pr=false, and sum, a variable which alter between calls to Test sub, through events.
Try the code. Any suggestions or improvements will be appreciated.
Last edited by georgekar; Nov 8th, 2021 at 09:13 PM.
Dim EventTool As clsObjectExtender
Dim oXmlhttp As WinHttp.WinHttpRequest
Private Sub Command1_Click()
Set EventTool = New clsObjectExtender
Set oXmlhttp = New WinHttpRequest
'Set oXmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
EventTool.Attach oXmlhttp
oXmlhttp.Open "GET", "https://www.baidu.com", True
oXmlhttp.Send
'strOut = oXmlhttp.responseText
End Sub
Public Sub EventRaised(oTarget As Object, ByVal ID As Long, ByVal strName As String, params() As Variant)
Debug.Print "event:" & strName
End Sub
If you open winhttpcom.dll typelib (i.e. the one with WinHttpRequest coclass) you can see that its events are declared in IWinHttpRequestEvents interface
. . . which is not a normal dispinterface like events from VB6 classes are implemented so this one is a bit weird.
Furthermore it's a little known fact that events from WinHttpRequest instances might be raised on worker threads and so very bad things can happen in VB6 handlers as no synchronization is provided on accessing instance private data (no COM marshalling). For instance putting a breakpoint in OnResponseDataAvailable and pressing End button in IDE might crash it.
If you open winhttpcom.dll typelib (i.e. the one with WinHttpRequest coclass) you can see that its events are declared in IWinHttpRequestEvents interface
. . . which is not a normal dispinterface like events from VB6 classes are implemented so this one is a bit weird.
Furthermore it's a little known fact that events from WinHttpRequest instances might be raised on worker threads and so very bad things can happen in VB6 handlers as no synchronization is provided on accessing instance private data (no COM marshalling). For instance putting a breakpoint in OnResponseDataAvailable and pressing End button in IDE might crash it.
cheers,
</wqw>
I thought it was a callback in a multithreaded function, so I tried every function plus multithreaded VB6 header initialization also didn't work. Just crashed. No warning. It's weird. Maybe this isn't a normal event connection after all.
I don't know if there's any other way.
i don't khnow whats' this?
Code:
Implements olelib.IOleClientSite
'Implements olelib.IConnectionPoint
Implements olelib2.IOleInPlaceSite
Call CoCreateInstance(CLSID_WebBrowser, Nothing, CLSCTX_INPROC_SERVER, IID_IWebBrowser2, oUnk)
CLSIDFromStringGUID StrPtr("{00000112-0000-0000-C000-000000000046}"), UUID2
oUnk.QueryInterface UUID2, IOleObject2
Dim pClientSite As IOleClientSite
Hr = oUnk.QueryInterface(UUID2, pClientSite)
MsgBox "h0=" & Hr
' Get the WebBrowser interface
'' Set m_oWebBrowser = objWeb ' oUnk
Set m_oWebBrowser = oUnk
Hr = oUnk.QueryInterface(IID_IConnectionPointContainer, pCPC)
Dim pCP As IConnectionPoint
pCPC.EnumConnectionPoints
Set pCP = pCPC.FindConnectionPoint(IID__IAddEvents)
Private Function IOleInPlaceSite_GetWindow() As Long
IOleInPlaceSite_OnUIActivate
maybe IOleInPlaceSite is ie event point?
if you want do datagrid events,also user FindConnectionPoint?
This is a method that needs to implement every event function. Make a separate class for each COM object type.
There are 30 COM DLLS that need to implement 30 CLASS files.
The late binding event method can support any COM DLL,OCX, without the need to implement any event entity.
Dim oITypeInfo As olelib.ITypeInfo
Dim oDispatch As olelib.IDispatch
Set oDispatch = obj
Set oITypeInfo = oDispatch.GetTypeInfo(0, 2052)
Call oITypeInfo.GetNames(dispid, strName, 1)
Code:
Private Function GetMemberName(obj As Object, ByVal dispid As Long, iid As UUID) As String
Dim oTypeLib As ITypeLib
Dim pTypeLib As Long
Dim pVTblTpLib As Long
Dim oTypeInfo As ITypeInfo
Dim pTypeInfo As Long
Dim pVTblTpInfo As Long
Dim oDispatch As IDispatch
Dim hRet As Long
Dim dwIndex As Long
Dim pcNames As Long
Dim pVTbl As Long
Dim strName As String
' get IDispatch from the object
pVTbl = ObjPtr(obj)
CpyMem pVTbl, ByVal pVTbl, 4
CpyMem oDispatch, ByVal pVTbl, Len(oDispatch)
' get ITypeInfo
hRet = CallPointer(oDispatch.GetTypeInfo, ObjPtr(obj), 0, LCID, VarPtr(pTypeInfo))
If hRet Then Exit Function
' ITypeInfo VTable
CpyMem pVTblTpInfo, ByVal pTypeInfo, 4
CpyMem oTypeInfo, ByVal pVTblTpInfo, Len(oTypeInfo)
' let's first ty to get the name
' of the member by using the current TypeInfo
hRet = CallPointer(oTypeInfo.GetNames, pTypeInfo, dispid, VarPtr(strName), 1, VarPtr(pcNames))
If Len(strName) > 0 Then
GetMemberName = strName
Exit Function
End If
' no, that didn't work.
' go for the whole type library
' GetContainingTypeLib
hRet = CallPointer(oTypeInfo.GetContainingTypeLib, pTypeInfo, VarPtr(pTypeLib), VarPtr(dwIndex))
If hRet Then
GetMemberName = dispid
Exit Function
End If
' ITypeLib VTable
CpyMem pVTblTpLib, ByVal pTypeLib, 4
CpyMem oTypeLib, ByVal pVTblTpLib, Len(oTypeLib)
' GetTypeInfoOfGUID
hRet = CallPointer(oTypeLib.GetTypeInfoOfGuid, pTypeLib, VarPtr(iid_event), VarPtr(pTypeInfo))
If hRet Then
GetMemberName = dispid
Exit Function
End If
' ITypeInfo VTable
CpyMem pVTblTpInfo, ByVal pTypeInfo, 4
CpyMem oTypeInfo, ByVal pVTblTpInfo, Len(oTypeInfo)
' GetNames
hRet = CallPointer(oTypeInfo.GetNames, pTypeInfo, dispid, VarPtr(strName), 1, VarPtr(pcNames))
If Len(strName) = 0 Then
' no string... :(
' instead return the dispip
GetMemberName = dispid
Else
GetMemberName = strName
End If
End Function
Actually I take it back; twinBASIC can run this on 32bit, right now. The problem was I had DEP on.
So it would be a lot of work to convert this to x64, since there's tons of raw pointer math and manipulation, but the biggest roadblock by far will be finding someone who can rewrite the assembly for x64 (I can't).
@wqweto... It doesn't seem like DispCallFunc could replace much of the asm, which is already using CallWindowProc? But then I don't know. It would be nice to have a generic call-by-pointer for x64.
@fafalone: This can invoke Long/HRESULT returning function pointers
Code:
'--- Module1
Option Explicit
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
Public Function DispCallByPfn(ByVal lPfn As Long, ParamArray A() As Variant) As Variant
Const CC_STDCALL As Long = 4
Dim lIdx As Long
Dim vParam() As Variant
Dim vType(0 To 63) As Integer
Dim vPtr(0 To 63) As Long
Dim hResult As Long
vParam = A
For lIdx = 0 To UBound(vParam)
vType(lIdx) = VarType(vParam(lIdx))
vPtr(lIdx) = VarPtr(vParam(lIdx))
Next
hResult = DispCallFunc(0, lPfn, CC_STDCALL, vbLong, lIdx, vType(0), vPtr(0), DispCallByPfn)
If hResult < 0 Then
Err.Raise hResult, "DispCallFunc"
End If
End Function
Code:
'--- Module2
Option Explicit
Public Function Test(ByVal lA As Long, ByVal lB As Long) As Long
Test = lA + lB
End Function
Code:
'--- Form1
Option Explicit
Private Sub Form_Load()
Debug.Print DispCallByPfn(AddressOf Test, 5, 6)
End Sub
I've seen that method before but is it a replacement for how it's being done in the project in this thread? When people use asm thunks my initial presumption is there's a damn good reason for the extra trouble, though not knowing assembly myself in anything more than the most general sense, that may or may not be accurate.
Yeah 64bit VBA does not like you doing anything with pointers *at all*.
I've been frustrated for months because a simple callback doesn't work.
Code:
Public Function TaskDialogCallbackProc(ByVal hWnd As LongPtr, ByVal uNotification As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr, ByVal lpRefData As LongPtr) As LongPtr
Dim cTD As cTaskDialog
CopyMemory cTD, lpRefData, LenB(lpRefData)
TaskDialogCallbackProc = cTD.zz_ProcessCallback(hWnd, uNotification, wParam, lParam)
ZeroMemory cTD, LenB(lpRefData)
End Function
I'm 100% sure I'm setting the AddressOf at the correct position (140/0x8C), but it crashes every single time (it works in twinBASIC in both 32 and 64bit, and VB6 in 32bit). Near as I can tell it never even enters the callback; tried breakpoints and signalling on the first line.
Yeah 64bit VBA does not like you doing anything with pointers *at all*.
I've been frustrated for months because a simple callback doesn't work.
Code:
Public Function TaskDialogCallbackProc(ByVal hWnd As LongPtr, ByVal uNotification As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr, ByVal lpRefData As LongPtr) As LongPtr
Dim cTD As cTaskDialog
CopyMemory cTD, lpRefData, LenB(lpRefData)
TaskDialogCallbackProc = cTD.zz_ProcessCallback(hWnd, uNotification, wParam, lParam)
ZeroMemory cTD, LenB(lpRefData)
End Function
I'm 100% sure I'm setting the AddressOf at the correct position (140/0x8C), but it crashes every single time (it works in twinBASIC in both 32 and 64bit, and VB6 in 32bit). Near as I can tell it never even enters the callback; tried breakpoints and signalling on the first line.
Sorry I'm having some trouble understanding the connection with that post... I'm not redirecting a vtable entry...
I have a class module that fills out a UDT for TaskDialogIndirect, which includes the AddressOf the callback function in my post, which is located in a standard .bas module, not a class module, and the ref data is set to ObjPtr(class module). This works in some other scenarios; wqweto says timers work, without adding any extra members to account for a different signature.
Reply With Quote
Originally Posted by wqweto
