Script Callback Functions

Sometimes our COM component must send a notification to the client or call the callback function. The scheme is simple: the component publishes the interface, the client creates an object inherited from the interface and passes it to the component, the component in turn calls the interface functions, thereby calling the functions on the client side.

In the case of Visual Basic or Visual Basic for Applicatons, we can write a class inherited from any interface, but this is not possible for VBScript script files.

Here the IDispatch interface rushes to our aid. Using this interface, our powerful component will humbly assume the modest role of a client, and a small script will turn into a real automation server.

We will develop the component in the FreeBASIC programming language.

Classes in the script file

You can declare and use classes in script files. Such classes are implicitly inherited from the IDispatch interface and are real COM classes.

We declare a class, an instance of which we will subsequently pass to our component:

 Class CallBack Function CallBack(Param) '    WScript.Echo Param CallBack = 0 End Function End Class 

Our component will receive an instance of the CallBack class, call the CallBack function and pass it a string with text in the parameter.

 '  Dim Component Set Component = CreateObject("BatchedFiles.TestCOMServer") '    ,      Dim objCallBack Set objCallBack = New CallBack '       Component.SetCallBack objCallBack, "" '       result = Component.InvokeCallBack() WScript.Echo result Set objCallBack = Nothing Set Component = Nothing 

IDispatch

This interface is a stumbling block to automation. Typically, the implementation of IDispatch based on a type library through ITypeInfo->Invoke or the CreateStdDispatch function, but in this case the automation server is located in a script and does not have a type library, and our component acts as a client. To simplify, IDipatch works like this: takes the name of the function and transfers control to it.

The definition of the interface lies in the header “oaidl.bi” (indents and line breaks are added for readability):

 Type IDispatch As IDispatch_ Type LPDISPATCH As IDispatch Ptr Type IDispatchVtbl '   IUnknown Dim InheritedTable As IUnknownVtbl GetTypeInfoCount As Function( _ ByVal this As IDispatch Ptr, _ ByVal pctinfo As UINT Ptr _ )As HRESULT GetTypeInfo As Function( _ ByVal this As IDispatch Ptr, _ ByVal iTInfo As UINT, _ ByVal lcid As LCID, _ ByVal ppTInfo As ITypeInfo Ptr Ptr _ )As HRESULT GetIDsOfNames As Function( _ ByVal this As IDispatch Ptr, _ ByVal riid As Const IID Const Ptr, _ ByVal rgszNames As LPOLESTR Ptr, _ ByVal cNames As UINT, _ ByVal lcid As LCID, _ ByVal rgDispId As DISPID Ptr _ )As HRESULT Invoke As Function( _ ByVal this As IDispatch Ptr, _ ByVal dispIdMember As DISPID, _ ByVal riid As Const IID Const Ptr, _ ByVal lcid As LCID, _ ByVal wFlags As WORD, _ ByVal pDispParams As DISPPARAMS Ptr, _ ByVal pVarResult As VARIANT Ptr, _ ByVal pExcepInfo As EXCEPINFO Ptr, _ ByVal puArgErr As UINT Ptr _ )As HRESULT End Type Type IDispatch_ lpVtbl As IDispatchVtbl Ptr End Type 

The GetIDsOfNames and Invoke functions are most interesting in this interface.

GetIDsOfNames

It takes the name of the function and returns its dispatch identifier DISPID . DISPID is an alias for the LONG type.

From the client’s point of view, DISPID is simply an optimization tool that avoids passing strings. For the server, DISPID is the identifier of the function that the client wants to call.

Invoke

By dispatch identifier performs the corresponding function.

DISPPARAMS

This structure contains the parameters of the called function. All parameters are packaged in VARIANT .

 Type tagDISPPARAMS '      rgvarg As VARIANTARG Ptr '      rgdispidNamedArgs As DISPID Ptr '    cArgs As UINT '    cNamedArgs As UINT End Type Type DISPPARAMS As tagDISPPARAMS 

To simplify the code, we will not use named arguments, we will set NULL instead.

Component

For use in scripts, components should also directly or indirectly inherit from IDipatch .

ITestCOMServer Interface

ITestCOMServer build the ITestCOMServer interface with two functions SetCallBack and InvokeCallBack . The first will save the automation server object, the second will call the object function.

 Type ITestCOMServer As ITestCOMServer_ Type LPITESTCOMSERVER As ITestCOMServer Ptr Type ITestCOMServerVirtualTable '   IDispatch Dim InheritedTable As IDispatchVtbl Dim SetCallBack As Function( _ ByVal this As ITestCOMServer Ptr, _ ByVal CallBack As IDispatch Ptr, _ ByVal UserName As BSTR _ )As HRESULT Dim InvokeCallBack As Function( _ ByVal this As ITestCOMServer Ptr _ )As HRESULT End Type Type ITestCOMServer_ Dim pVirtualTable As ITestCOMServerVirtualTable Ptr End Type 

Class TestCOMServer

Now you can declare a COM ‐ class:

 Type TestCOMServer '      Dim pVirtualTable As ITestCOMServerVirtualTable Ptr '   Dim ReferenceCounter As ULONG '    Dim CallBackObject As IDispatch Ptr '   Dim UserName As BSTR End Type 

Function setcallback

The implementation of the SetCallBack function SetCallBack simple: we save the automation server object transmitted by the client and the function call parameter.

 Function TestCOMServerSetCallBack( _ ByVal pTestCOMServer As TestCOMServer Ptr, _ ByVal CallBack As IDispatch Ptr, _ ByVal UserName As BSTR _ )As HRESULT '      ,      If pTestCOMServer->CallBackObject <> NULL Then IDispatch_Release(pTestCOMServer->CallBack) End If pTestCOMServer->CallBackObject = CallBack '    If pTestCOMServer->CallBackObject <> NULL Then IDispatch_AddRef(pTestCOMServer->CallBack) End If '    SysFreeString(pTestCOMServer->UserName) '      pTestCOMServer->UserName = SysAllocStringLen(UserName, SysStringLen(UserName)) Return S_OK End Function 

InvokeCallBack Function

But the InvokeCallBack function will InvokeCallBack to work hard. First you need to get the dispatcher identifier of the CallBack function of the automation server.

 Function TestCOMServerInvokeCallBack( _ ByVal pTestCOMServer As TestCOMServer Ptr _ )As HRESULT If pTestCOMServer->CallBack = NULL Then Return E_POINTER End If '    Const cNames As UINT = 1 '     Dim rgszNames(cNames - 1) As WString Ptr = {@"CallBack"} '   DISPID Dim rgDispId(cNames - 1) As DISPID = Any Dim hr As HRESULT = IDispatch_GetIDsOfNames( _ pTestCOMServer->CallBackObject, _ @IID_NULL, _ @rgszNames(0), _ cNames, _ GetUserDefaultLCID(), _ @rgDispId(0) _ ) If FAILED(hr) Then MessageBoxW(NULL, "  DISPID", NULL, MB_OK) Return E_FAIL End If 

After the DISPID function is received, it can be called:

  '     «, %UserName%» Dim Greetings As BSTR = SysAllocString(", ") Dim GreetingsUserName As BSTR = Any VarBstrCat(Greetings, pTestCOMServer->UserName, @GreetingsUserName) Const ParamsCount As Integer = 1 '    Dim varParam(ParamsCount - 1) As VARIANT = Any For i As Integer = 0 To ParamsCount - 1 VariantInit(@varParam(i)) Next '   —  varParam(0).vt = VT_BSTR varParam(0).bstrVal = GreetingsUserName Dim Params(0) As DISPPARAMS = Any Params(0).rgvarg = @varParam(0) Params(0).cArgs = ParamsCount Params(0).rgdispidNamedArgs = NULL Params(0).cNamedArgs = 0 '      Dim VarResult As VARIANT = Any Dim ExcepInfo As EXCEPINFO = Any Dim uArgErr As UINT = Any '     hr = IDispatch_Invoke( _ pTestCOMServer->CallBackObject, _ rgDispId(0), _ @IID_NULL, _ GetUserDefaultLCID(), _ DISPATCH_METHOD, _ @Params(0), _ @VarResult, _ NULL, _ NULL _ ) '    For i As Integer = 0 To ParamsCount - 1 VariantClear(@varParam(i)) Next SysFreeString(Greetings) Return S_OK End Function 

Output

As you can see, even with a script file, a component can receive feedback. This is useful for notifying the client of completed operations by the component.

Classes in scripts can be registered in the registry, in which case they will be available for the whole system using ProgID , but this is a completely different story.

References

Project code on the github site: https://github.com/zamabuvaraeu/TestCOMServer

PS Somehow the highlight for the BASIC syntax disappeared, instead it used VBScript, and some operators are not highlighted with it.