脚本回调函数

有时，我们的COM组件必须向客户端发送通知或调用回调函数。 该方案很简单：组件发布接口，客户端创建一个从接口继承的对象，并将其传递给组件，该组件依次调用接口函数，从而在客户端调用这些函数。

对于Visual Basic或Visual Basic for Applicatons，我们可以编写一个从任何接口继承的类，但这对于VBScript脚本文件是不可能的。

在这里， IDispatch界面可为我们提供帮助。 使用此接口，我们功能强大的组件将谦虚地承担客户端的角色，而小的脚本将变成真正的自动化服务器。

我们将使用FreeBASIC编程语言开发该组件。

脚本文件中的类

您可以在脚本文件中声明和使用类。 这些类是从IDispatch接口隐式继承的，并且是真正的COM类。

我们声明一个类，该类的实例随后将传递给我们的组件：

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

我们的组件将接收CallBack类的实例，调用CallBack函数，并向其传递参数中包含文本的字符串。

 '  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

该接口是自动化的绊脚石。 通常， IDispatch的实现基于通过ITypeInfo->Invoke或CreateStdDispatch函数的类型库，但是在这种情况下，自动化服务器位于脚本中并且没有类型库，并且我们的组件充当客户端。 为简化起见， IDipatch工作方式如下：获取函数的名称并将控制权转移给它。

接口的定义位于标题“ oaidl.bi”中（为了便于阅读，添加了缩进和换行符）：

 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 

GetIDsOfNames和Invoke函数在此界面中最有趣。

GetIDsOfNames

它使用函数的名称并返回其调度标识符DISPID 。 DISPID是LONG类型的别名。

从客户的角度来看， DISPID只是一种避免字符串传递的优化工具。 对于服务器， DISPID是客户端要调用的功能的标识符。

调用

通过调度标识符执行相应的功能。

发行

此结构包含被调用函数的参数。 所有参数都打包在VARIANT 。

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

为了简化代码，我们将不使用命名参数，而是将其设置为NULL 。

组成部分

为了在脚本中使用，组件还应该直接或间接继承自IDipatch 。

ITestCOMServer接口

ITestCOMServer使用两个函数SetCallBack和InvokeCallBack构建ITestCOMServer接口。 第一个将保存自动化服务器对象，第二个将调用对象函数。

 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 

类TestCOMServer

现在您可以声明一个COM类：

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

函数设置回调

SetCallBack函数的实现SetCallBack简单：我们保存由客户端传输的自动化服务器对象和函数调用参数。

 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函数

但是InvokeCallBack函数将InvokeCallBack努力工作。 首先，您需要获取自动化服务器的CallBack函数的调度程序标识符。

 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 

收到函数的DISPID ，可以将其调用：

  '     «, %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 

结论

如您所见，即使使用脚本文件，组件也可以获取反馈。 这对于将组件已完成的操作通知给客户端非常有用。

脚本中的类可以在注册表中注册，在这种情况下，可以使用ProgID在整个系统中使用它们，但这是一个完全不同的故事。

参考文献

github站点上的项目代码： https : //github.com/zamabuvaraeu/TestCOMServer

PS不知何故，BASIC语法的突出显示消失了，取而代之的是它使用了VBScript，并且某些运算符也没有突出显示。