Clever Geek Handbook

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.







Parameter Description
riid Reserved. A pointer to IID_NULL should be passed.
rgszNames An array of function names for which it is necessary to return dispatch identifiers.
cNames The size of the array.
lcid Localization information.
rgDispId An array where the function will write DISPID



for each function name or DISPID_UNKNOWN



if it does not find a function with that name.


Invoke



By dispatch identifier performs the corresponding function.







Parameter Description
dispIdMember Dispatcher identifier of the called function.
riid Reserved. A pointer to IID_NULL should be passed.
lcid Localization information.
wflags Flags type functions. For simple functions, set to DISPATCH_METHOD



, to get the property value - DISPATCH_PROPERTYGET



, to set the property value - DISPATCH_PROPERTYPUT



, by reference - DISPATCH_PROPERTYPUTREF



.
pDispParams Special structure with function call parameters.
pVarResult Pointer to the type VARIANT



where the function will bring the result of the work.
pExcepInfo A pointer to the structure where the function will write the thrown exception. Can be set to NULL



.
puArgErr The indices of the arguments that caused the error. Can be set to NULL



.


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.







More articles:


All Articles