Использование Microsoft ScriptControl
Пишем Invoke
Первая часть задачи выполнена: мы проинформировали OLE о наличии в нашем сервере автоматизации поддерживаемых функций. Теперь необходимо реализовать метод Invoke для выполнения этих функций. Из соображений модульности Invoke выполняет подготовительную работу со списком параметров и вызывает метод DoInvoke, в котором мы осуществляем трансляцию DispID в обращения к методам класса VCL.
В методе используются три служебные функции:
- проверяет количество переданных аргументов.
- проверяет соответствие аргумента с заданным индексом заданному типу.
- получает целое число из аргумента с заданным индексом.
TVCLProxy.DoInvoke(DispID: Integer; IID: TGUID; LocaleID: Integer; Flags: Word; dps: TDispParams; pDispIds: PDispIdList; VarResult, ExcepInfo, ArgErr: Pointer ): HResult; S: ; Put: Boolean; I: Integer; P: TPersistent; B: Boolean; OutValue: OleVariant;
Result := S_OK; DispId
Для функции Controls мы должны проверить, что передан один параметр. Если он строковый — поиск дочернего компонента будет происходить по имени, в противном случае — по индексу. Если компонент найден – вызывается функция FScriptControl.GetProxy, которая проверяет наличие «представителя» у этого компонента, при необходимости создает его и возвращает интерфейс IDispatch. Такой алгоритм необходим для корректной работы оператора VBScript Is, который сравнивает две ссылки на объект и выдает истину в случае, если речь идет об одном и том же объекте, например:
Dim A Dim B Set A = C Set B = C If A is B Then ...
Если создавать экземпляр класса TVCLProxy каждый раз, когда запрашивается ссылка, эти экземпляры окажутся разными и оператор Is не будет работать.
DISPID_CONTROLS:
// Вызвана функция Controls
FOwner TWinControl
// Проверяем параметр
CheckArgCount(dps.cArgs, [1], TRUE);
P := ;
_ValidType(0, VT_BSTR, FALSE)
// Если параметр - строка - ищем дочерний компонент
// с таким именем
S := dps.rgvarg^[pDispIds^[0]].bstrVal;
I := 0 Pred(ControlCount)
CompareText(S, Controls[I].Name) = 0
P := Controls[I];
Break;
;
// Иначе - параметр - число, берем компонент по индексу
I := _IntValue(0);
P := Controls[I];
;
Assigned(P)
// Компонент не найден
EInvalidParamType.Create('');
// Возвращаем интерфейс IDispatch для найденного компонента
OleVariant(VarResult^) := FScriptControl.GetProxy(P);
;
;
Функция Count должна вызываться без параметров и призвана возвращать количество элементов в запрашиваемом объекте.
DISPID_COUNT: // Вызвана функция Count // Проверяем, что не было параметров CheckArgCount(dps.cArgs, [0], TRUE); FOwner TWinControl // Возвращаем количество дочерних компонентов OleVariant(VarResult^) := TWinControl(FOwner).ControlCount; FOwner TCollection // Возвращаем количество элементов коллекции OleVariant(VarResult^) := TCollection(FOwner).Count FOwner TStrings // Возвращаем количество строк OleVariant(VarResult^) := TStrings(FOwner).Count; ;
Метод Add добавляет элемент к объекту-владельцу «представителя». Обратите внимание на реализацию необязательных параметров для TWinControl и TStrings.
DISPID_ADD: // Вызвана функция Add FOwner TWinControl // Проверяем количество аргументов CheckArgCount(dps.cArgs, [2,3], TRUE); // Проверяем типы обязательных аргументов _ValidType(0, VT_BSTR, TRUE); _ValidType(1, VT_BSTR, TRUE); // Третий аргумент - необязательный, если он не задан - // полагаем FALSE (dps.cArgs = 3) _ValidType(2, VT_BOOL, TRUE) B := dps.rgvarg^[pDispIds^[0]].vbool B := FALSE; // Вызываем метод для создания компонента DoCreateControl(dps.rgvarg^[pDispIds^[0]].bstrVal, dps.rgvarg^[pDispIds^[1]].bstrVal, B); FOwner TCollection // Добавляем компонент P := TCollection(FOwner).Add; // И возвращаем его интерфейс IDispatch OleVariant(varResult^) := FScriptControl.GetProxy(P); FOwner TStrings // Проверяем наличие аргументов CheckArgCount(dps.cArgs, [1,2], TRUE); // Проверяем, что аргумент – строка _ValidType(0, VT_BSTR, TRUE); dps.cArgs = 2 then // Второй аргумент - позиция в списке I := _IntValue(1) // Если его нет - вставляем в конец I := TStrings(FOwner).Count; // Добавляем строку TStrings(FOwner).Insert(I, dps.rgvarg^[pDispIds^[0]].bstrVal); ; ;
И наконец, функция HasProperty проверяет наличие у объекта VCL опубликованного свойства с заданным именем.
DISPID_HASPROPERTY: // Вызвана функция HasProperty // Проверяем наличие аргумента CheckArgCount(dps.cArgs, [1], TRUE); // Проверяем тип аргумента _ValidType(0, VT_BSTR, TRUE); S := dps.rgvarg^[pDispIds^[0]].bstrVal; // Возвращаем True, если свойство есть OleVariant(varResult^) := Assigned(GetPropInfo(FOwner.ClassInfo, S)); ;
Если ни один из DispID не обработан — значит DispID содержит адрес структуры TPropInfo свойства VCL
// Это не наша функция, значит это свойство // Проверяем Flags, чтобы узнать, устанавливается значение // или получается Put := (Flags DISPATCH_PROPERTYPUT) <> 0; Put // Устанавливаем значение // Проверяем наличие аргумента CheckArgCount(dps.cArgs, [1], TRUE); // И устанавливаем свойство Result := SetVCLProperty(PPropInfo(DispId), dps.rgvarg^[pDispIds^[0]]) // Получаем значение DispId = 0 // DispId = 0 - требуется свойство по умолчанию // Возвращаем свой IDispatch OleVariant(VarResult^) := Self IDispatch; Exit; ; // Получаем значение свойства Result := GetVCLProperty(PPropInfo(DispId), dps, pDispIds, OutValue); Result = S_OK // Получили успешно - сохраняем результат OleVariant(VarResult^) := OutValue; ; ; ;
Добавление собственных функций
Для добавления функций, которые требуются для решения ваших задач, необходимо выполнить ряд простых шагов:
- В методе GetIdsOfNames проанализировать имя запрашиваемой функции и определить, может ли она быть вызвана для объекта, на который ссылается FOwner.
- Если функция может быть вызвана, вы должны вернуть уникальный DispID, в противном случае – присвоить Result := DISP_E_UNKNOWNNAME.
- В методе Invoke необходимо обнаружить свой DispID, проверить корректность переданных параметров, получить их значения и выполнить действие.
Обработка событий в компонентах VCL
Важным дополнением к реализуемой функциональности является возможность ассоциировать процедуру на VBScript с событием в компоненте VCL, таким как OnEnter, OnClick или OnTimer. Для этого добавим в компонент TVCLScriptControl методы, которые будут служить обработчиками созданных в коде скрипта компонентов.
TVCLScriptControl = (TScriptControl) … OnChangeHandler(Sender: TObject); OnClickHandler(Sender: TObject); OnEnterHandler(Sender: TObject); OnExitHandler(Sender: TObject); OnTimerHandler(Sender: TObject); ;
В методе DoCreateControl, который вызывается из DoInvoke при обработке метода «Add», реализуем подключение соответствующих обработчиков событий создаваемого компонента к созданным методам.
TVCLProxy.DoCreateControl(AName, AClassName: WideString; WithEvents: Boolean); SetHandler(Control: TPersistent; Owner: TObject; Name: String); // Функция устанавливает обработчик события Name на метод формы // с именем Name + 'Handler' Method: TMethod; PropInfo: PPropInfo; // Получаем информацию RTTI PropInfo := GetPropInfo(Control.ClassInfo, Name); Assigned(PropInfo) // Получаем адрес обработчика Method.Code := FScriptControl.MethodAddress(Name + 'Handler'); Assigned(Method.Code) // Обработчик есть Method.Data := FScriptControl; // Устанавливаем обработчик SetMethodProp(Control, PropInfo, Method); ; ; ;
ThisClass: TControlClass; C: TComponent; NewOwner: TCustomForm; // Назначаем свойство Owner на форму (FOwner TCustomForm) NewOwner := GetParentForm(FOwner TControl) NewOwner := FOwner TCustomForm; // Получаем класс создаваемого компонента ThisClass := TControlClass(GetClass(AClassName)); // Создаем компонент C := ThisClass.Create(NewOwner); // Назначаем имя C.Name := AName; C TControl // Назначаем свойство Parent TControl(C).Parent := FOwner TWinControl; WithEvents // Устанавливаем обработчики SetHandler(C, NewOwner, 'OnClick'); SetHandler(C, NewOwner, 'OnChange'); SetHandler(C, NewOwner, 'OnEnter'); SetHandler(C, NewOwner, 'OnExit'); SetHandler(C, NewOwner, 'OnTimer'); ; // Создаем класс, реализующий интерфейс Idispatch, и добавляем его // в пространство имен TScriptControl FScriptControl.RegisterClass(AName, C); ;
Таким образом, если третьим параметром метода «Add» будет задано True, то TVCLScriptControl установит обработчики событий OnClick, OnChange, OnEnter, OnExit и OnTimer на свои методы, реализованные следующим образом:
TVCLScriptControl.OnClickHandler(Sender: TObject); RunProc((Sender TComponent).Name + '_' + 'OnClick'); ;
Примером использования данной функциональности может служить следующий код:
Sub Main() Self.Add "Timer1", "TTimer", TRUE With Timer1 .Interval = 1000 .Enabled = True End With End Sub Sub Timer1_OnTimer() Self.Caption = CStr(Time) End Sub
Если требуется назначить обработчики событий, имеющихся на форме компонентов, это может быть сделано в коде
Button1.OnClick := ScriptControl1.OnClickHandler;
или путем реализации соответствующего метода в GetIdsOfNames и Invoke.
Получение свойств
Для получения свойств классов VCL служит метод GetVCLProperty. В нем осуществляется трансляция типов данных Object Pascal в типы данных OLE.
TVCLProxy.GetVCLProperty(PropInfo: PPropInfo; dps: TDispParams; PDispIds: PDispIdList; Value: OleVariant ): HResult; I, J, K: Integer; S: String; P, P1: TPersistent; Data: PTypeData; DT: TDateTime; TypeInfo: PTypeInfo; Result := S_OK; PropInfo^.PropType^.Kind
Для данных строкового и целого типа Delphi осуществляет автоматическую трансляцию.
tkString, tkLString, tkWChar, tkWString: // Символьная строка Value := GetStrProp(FOwner, PropInfo);
tkChar, tkInteger: // Целое число Value := GetOrdProp(FOwner, PropInfo);
Для перечисленных типов OLE не имеет прямых аналогов. Поэтому для всех типов, кроме Boolean, будем передавать символьную строку с именем соответствующей константы. Для Boolean имеется подходящий тип данных, и этот случай необходимо обрабатывать отдельно.
tkEnumeration: // Проверяем, не Boolean ли это CompareText(PropInfo^.PropType^.Name, 'BOOLEAN') = 0 // Передаем как Boolean Value := Boolean(GetOrdProp(FOwner, PropInfo)); // Остальные - передаем как строку I := GetOrdProp(FOwner, PropInfo); Value := GetEnumName(PropInfo^.PropType^, I); ; ;
Самым сложным случаем является свойство объектного типа. Нормальным поведением будет возврат интерфейса IDispatch, позволяющего OLE обращаться к методам класса, на который ссылается свойство. Однако для некоторых классов, имеющих свойства «по умолчанию», таких как TStrings и TСollection, свойство может быть запрошено с индексом. В этом случае следует выдать соответствующий индексу элемент. В то же время, будучи запрошенным без индекса, свойство должно выдать интерфейс IDispatch для работы с экземпляром TCollection или TStrings.
tkClass: // Получаем значение свойства P := TPersistent(GetOrdProp(FOwner, PropInfo)); Assigned(P) (P TCollection) (dps.cArgs = 1) // Запрошен элемент коллекции с индексом (есть параметр) ValidType(dps.rgvarg^[pDispIds^[0]], VT_BSTR, FALSE) // Параметр строковый, ищем элемент по свойству // DisplayName S := dps.rgvarg^[pDispIds^[0]].bstrVal; P1 := ; I := 0 Pred(TCollection(P).Count) CompareText(S, TCollection(P).Items[I].DisplayName) = 0 P1 := TCollection(P).Items[I]; Break; ; Assigned(P1) // Найден - возвращаем интерфейс IDispatch Value := FScriptControl.GetProxy(P1) // Не найден Result := DISP_E_MEMBERNOTFOUND; // Параметр целый, возвращаем элемент по индексу I := IntValue(dps.rgvarg^[pDispIds^[0]]); (I >= 0) and (I < TCollection(P).Count) P := TCollection(P).Items[I]; Value := FScriptControl.GetProxy(P); Result := DISP_E_MEMBERNOTFOUND; ;
Для класса TStrings результатом будет не интерфейс, а строка, выбранная по имени или по индексу.
Assigned(P) (P TStrings) (dps.cArgs = 1) // Запрошен элемент из Strings с индексом (есть параметр) ValidType(dps.rgvarg^[pDispIds^[0]], VT_BSTR, FALSE) // Параметр строковый - возвращаем значение свойства // Values S := dps.rgvarg^[pDispIds^[0]].bstrVal; Value := TStrings(P).Values[S]; // Параметр целый, возвращаем строку по индексу I := IntValue(dps.rgvarg^[pDispIds^[0]]); (I >= 0) (I < TStrings(P).Count) Value := TStrings(P)[I] Result := DISP_E_MEMBERNOTFOUND; ; // Общий случай, возвращаем интерфейс IDispatch свойства Assigned(P) Value := FScriptControl.GetProxy(P) // Или Unassigned, если оно = NIL Value := Unassigned; ;
У чисел с плавающей точкой также есть особенный тип данных – TDateTime. Его необходимо обрабатывать иначе, чем остальные числа с плавающей точкой, поскольку у него в OLE есть отдельный тип данных — OleDate.
tkFloat: (PropInfo^.PropType^ = System.TypeInfo(TDateTime)) (PropInfo^.PropType^ = System.TypeInfo(TDate)) //Помещаем значение свойства в промежуточную // переменную типа TDateTime DT := GetFloatProp(FOwner, PropInfo); Value := DT; Value := GetFloatProp(FOwner, PropInfo); ;
В случае свойства типа «набор» (Set), не имеющего аналогов в OLE, будем возвращать строку с установленными значениями набора, перечисленными через запятую.
tkSet: // Получаем значение свойства (битовая маска) I := GetOrdProp(FOwner, PropInfo); // Получаем информацию RTTI Data := GetTypeData(PropInfo^.PropType^); TypeInfo := Data^.CompType^; // Формируем строку с набором значений S := ''; I <> 0 K := 0 31 J := 1 K; (J I) = J S := S + GetEnumName(TypeInfo, K) + ','; ; // Удаляем запятую в конце System.Delete(S, Length(S), 1); ; Value := S; ;
И наконец, с типом Variant не возникает никаких сложностей.
tkVariant: Value := GetVariantProp(FOwner, PropInfo); // Остальные типы не поддерживаются Result := DISP_E_MEMBERNOTFOUND; ; ;
Установка свойств
Для установки свойств классов VCL служит метод SetVCLProperty. В нем осуществляется обратная трансляция типов данных OLE в типы данных Object Pascal.
TVCLProxy.SetVCLProperty(PropInfo: PPropInfo; Argument: TVariantArg): HResult; I, J, K, CommaPos: Integer; GoodToken: Boolean; S, S1: ; DT: TDateTime; ST: TSystemTime; IP: IQueryPersistent; Data, TypeData: PTypeData; TypeInfo: PTypeInfo; Result := S_OK; PropInfo^.PropType^.Kind
Главным отличием этого метода от SetVCLProperty является необходимость проверки типа данных передаваемого параметра.
tkChar, tkString, tkLString, tkWChar, tkWString: // Проверяем тип параметра ValidType(Argument, VT_BSTR, TRUE); // И устанавливаем свойство SetStrProp(FOwner, PropInfo, Argument.bstrVal); ;
Для целочисленных свойств добавим еще один сервис (если свойство имеет тип TCursor или Tcolor) — обеспечим трансляцию символьной строки с соответствующим названием константы в целочисленный идентификатор.
tkInteger: // Проверяем тип свойства на TCursor, TColor, // если он совпадает и передано символьное значение, // пытаемся получить его идентификатор (CompareText(PropInfo^.PropType^.Name, 'TCURSOR') = 0) (Argument.vt = VT_BSTR) IdentToCursor(Argument.bstrVal, I) Result := DISP_E_BADVARTYPE; Exit; ; (CompareText(PropInfo^.PropType^.Name, 'TCOLOR') = 0) (Argument.vt = VT_BSTR) IdentToColor(Argument.bstrVal, I) Result := DISP_E_BADVARTYPE; Exit; ; // Просто цифра I := IntValue(Argument); // Устанавливаем свойство SetOrdProp(FOwner, PropInfo, I); ;
Для перечисленных типов, за исключением Boolean, значение передается в виде символьной строки, а Boolean, как и раньше, обрабатывается отдельно.
tkEnumeration:
// Проверяем на тип Boolean - для него в VBScript есть
// отдельный тип данных
CompareText(PropInfo^.PropType^.Name, 'BOOLEAN') = 0
// Проверяем тип данных аргумента
ValidType(Argument, VT_BOOL, TRUE);
// Это свойство Boolean - получаем значение и значение
SetOrdProp(FOwner, PropInfo, Integer(Argument.vBool));
// Перечисленный тип передается в виде символьной строки
// Проверяем тип данных аргумента
ValidType(Argument, VT_BSTR, TRUE);
// Получаем значение
S := Trim(Argument.bstrVal);
// Переводим в Integer
I := GetEnumValue(PropInfo^.PropType^, S);
// Если успешно - устанавливаем свойство
I >= 0
SetOrdProp(FOwner, PropInfo, I)
EInvalidParamType.Create('');
;
;
При установке объектного свойства необходимо получить ссылку на класс Delphi, представителем которого является переданный интерфейс IDispatch. Для этой цели служит ранее определенный нами интерфейс IQueryPersistent. Запросив его у объекта-представителя, мы можем получить ссылку на объект VCL и корректно установить свойство.
tkClass: // Проверяем тип данных - должен быть интерфейс IDispatch ValidType(Argument, VT_DISPATCH, TRUE); Assigned(Argument.dispVal) // Передано непустое значение // Получаем интерфейс IQueryPersistent IP := IDispatch(Argument.dispVal) IQueryPersistent; // Получаем ссылку на класс, представителем которого // является интерфейс I := Integer(IP.GetPersistent); // Иначе - очищаем свойство I := 0; // Устанавливаем значение SetOrdProp(FOwner, PropInfo, I); ;
Для чисел с плавающей точкой основной проблемой является отработка свойства типа TDateTime. Дополнительно обеспечим возможность установить это свойство в виде символьной строки. При установке свойства типа TDateTime необходимо обеспечить трансляцию его из формата TOleDate в TDateTime.
tkFloat: (PropInfo^.PropType^ = System.TypeInfo(TDateTime)) (PropInfo^.PropType^ = System.TypeInfo(TDate)) // Проверяем тип данных аргумента Argument.vt = VT_BSTR DT := StrToDate(Argument.bstrVal); ValidType(Argument, VT_DATE, TRUE); VariantTimeToSystemTime(Argument.date, ST) <> 0 DT := SystemTimeToDateTime(ST) Result := DISP_E_BADVARTYPE; Exit; ; ; SetFloatProp(FOwner, PropInfo, DT); // Проверяем тип данных аргумента ValidType(Argument, VT_R8, TRUE); // Устанавливаем значение SetFloatProp(FOwner, PropInfo, Argument.dblVal); ; ;
Наиболее сложным случаем является установка данных типа «набор» (Set). Необходимо выделить из переданной символьной строки разделенные запятыми элементы, для каждого из них – проверить, является ли он допустимым для устанавливаемого свойства, и установить соответствующий бит в числе, которое будет установлено в качестве свойства.
tkSet:
// Проверяем тип данных, должна быть символьная строка
ValidType(Argument, VT_BSTR, TRUE);
// Получаем данные
S := Trim(Argument.bstrVal);
// Получаем информацию RTTI
Data := GetTypeData(PropInfo^.PropType^);
TypeInfo := Data^.CompType^;
TypeData := GetTypeData(TypeInfo);
I := 0;
Length(S) > 0
// Проходим по строке, выбирая разделенные запятыми
// значения идентификаторов
CommaPos := Pos(',', S);
CommaPos = 0
CommaPos := Length(S) + 1;
S1 := Trim(System.Copy(S, 1, CommaPos - 1));
System.Delete(S, 1, CommaPos);
Length(S1) > 0
// Поверяем, какому из допустимых значений соответствует
// полученный идентификатор
K := 1;
GoodToken := FALSE;
J := TypeData^.MinValue TypeData^.MaxValue
CompareText(S1, GetEnumName(TypeInfo , J)) = 0
// Идентификатор найден, добавляем его в маску
I := I K;
GoodToken := TRUE;
;
K := K 1;
;
GoodToken
// Идентификатор не найдет
Result := DISP_E_BADVARTYPE;
Exit;
;
;
;
// Устанавливаем значение свойства
SetOrdProp(FOwner, PropInfo, I);
;
Свойство типа Variant установить несложно.
tkVariant: // Проверяем тип данных аргумента ValidType(Argument, VT_VARIANT, TRUE); // Устанавливаем значение SetVariantProp(FOwner, PropInfo, Argument.pvarVal^); ; // Остальные типы данных OLE не поддерживаются Result := DISP_E_MEMBERNOTFOUND; ; ;
Таким образом, мы реализовали полную функциональность по трансляции вызовов OLE в обращения к свойствам VCL. Наш компонент может динамически создавать другие компоненты на форме, обращаться к их свойствам и даже обрабатывать возникающие в них события.
