Иногда наш 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 — идентификатор функции, которую хочет вызвать клиент.

Параметр	Описание
riid	Зарезервировано. Следует передавать указатель на IID_NULL.
rgszNames	Массив имён функций, для которых необходимо вернуть диспетчерские идентификаторы.
cNames	Размер массива.
lcid	Информация локализации.
rgDispId	Массив, куда функция запишет `DISPID` для каждого имени функции или `DISPID_UNKNOWN` если не найдёт функцию с таким именем.

Invoke

По диспетчерскому идентификатору выполняет соответствующую функцию.

Параметр	Описание
dispIdMember	Диспетчерский идентификатор вызываемой функции.
riid	Зарезервировано. Следует передавать указатель на IID_NULL.
lcid	Информация локализации.
wFlags	Флаги типа функции. Для простых функций следует устанавливать в `DISPATCH_METHOD`, для получения значения свойства — `DISPATCH_PROPERTYGET`, для установки значения свойства — `DISPATCH_PROPERTYPUT`, по ссылке — `DISPATCH_PROPERTYPUTREF`.
pDispParams	Специальная структура с параметрами вызова функции.
pVarResult	Указатель на тип `VARIANT`, куда функция занесёт результат работы.
pExcepInfo	Указатель на структуру, куда функция запишет выброшенное исключение. Можно устанавливать в `NULL`.
puArgErr	Индексы аргументов, вызвавших ошибку. Можно устанавливать в `NULL`.

DISPPARAMS

В этой структуре содержатся параметры вызываемой функции. Все параметры упаковываются в 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. Первая будет сохранять объект сервера автоматизации, вторая — вызывать функцию объекта.

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 придётся потрудиться. Для начала необходимо получить диспетчерский идентификатор функции 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, но это уже совсем другая история.

Ссылки

Код проекта на сайте гитхаба: https://github.com/zamabuvaraeu/TestCOMServer

P.S. Куда‐то исчезла подсветка для BASIC‐синтаксиса, вместо него использовал VBScript, а с ним не подсвечиваются некоторые операторы.

Функции обратного вызова в скриптах