Шпаргалка. Использование Microsoft Script Control в приложениях - #1

Добрый день!

Поводом для этой шпаргалки стали мои мои попытки разобраться с работой MS Script Control.
Для начала оговорюсь сразу в этой заметке не будет детального описания работы для этого уже есть много материала в Интернете, например: "Использование Microsoft ScriptControl" ,

Здесь же пойдет речь о самой работе с Script Control, так сказать некоторые ньюансы его использования, предпологается что читатель уже имеет некоторое представление:

Создание объекта

Для того, что-бы создать объект и присоеденить его к Microsoft Script нужно реализовать класс поддерживающий интерфейс IDispatch. Т.к у нас все таки шпаргалка, я привожу класс-протитип для реализации  интерфейса IDispatch.

TBase = class(TInterfacedObject, IDispatch)
  private
  Protected
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall; Abstract;
      {
      DispID   - содержит диспетчерский идентификатор (dispatch ID), это число,
                 которое показывает какой метод должен быть вызван в сервере.
      IID      - на данный момент не используется
      LocaleID - содержит информацию о языке.
      Flags    - определяет какого типа метод будет вызван в сервере: метод
                 доступа к свойствам или обычный метод.
      Params   - содержит указатель на массив TDispParams, который содержит
                 параметры, передаваемые этому методу.
      VarResult- это указатель на переменную типа OleVariant, в которую будет
                 записано возвращаемое значение вызываемого метода.
      ExcepInfo- указатель на запись типа TExceptInfo, которая будет содержать
                 информацию об ошибке, в случае, если метод Invoke() возвращает значение
                 DISP_E_TYPEMISMATCH или DISP_E_PARAMNOTFOUND.
      ArgErr   - указатель на целое число (индекс некорректного параметра в массиве Params).
      }
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer)
      : HResult; virtual; stdcall; Abstract;
  public
     function  CheckArgCount(Count: Integer; Accepted: Integer; ExcepInfo : Pointer) : Boolean;
     function  IsValidType(Argument: TVariantArg; TypesId : Variant): Boolean;
     function  IsVdalidTypeBSTR(Argument: TVariantArg): Boolean;

     procedure VariantChangeTypeToBSTR(var Argument: TVariantArg);

     procedure SetErrorCheckParamsType(ExcepInfo : Pointer; MethodName : string = '');
     procedure SetErrorInfo(ExcepInfo : Pointer; Description : String;
                            MethodName : string = '');
  end;

В данный класс помимо реализации интерфейса IDispatch включены некоторые вспомогательные функции, такие как проверка типа, проверка кол-ва аргументов в процедуре или функции, генерация информации о ошибке для Script Control
Далее наследуя от этого класса мы и будем реализовывать собственный объект я назвал его MyClass который в последствии мы подключим к Script Control
Итак:

type
  TMyClass = class(TBase)
  Private
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; override; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; override; stdcall;
  public
  end;

Перекрывая   GetIDsOfNames и   Invoke реализуем собственную функциональность.

Далее для того что бы зарегистрировать данный объект в Script Control вызовем  ScriptControl.AddObject

ScriptControl.Language := 'VBScript';
ScriptControl.UseSafeSubset := False;
ScriptControl.AllowUI := true;
ScriptControl.Reset;
ScriptControl.AddObject('MYCLASS', TMyClass.Create as IDispatch  , FALSE);

Создание процедуры

Итак класс мы создали, теперь в данном классе нужно создать различные методы которые в будущем мы сможем вызывать со скрипта, т.к. самы простой метод это процедура (не возвращает никаких данных) то начнем с нее, для начала определимся в нашем классе будут следующие методы MESSAGEINFORMATION и GETRANDOMNUMBER. Первый будет выдавать диалоговое окно с сообщением которое будет посылатся в параметре, второй для тестового примера возращать случайное число.
Итак в начале создадим константы, и сделаем реализацию метода GetIDsOfNames

const
  DISPID_MessageInformation    = 1;
  fn_MESSAGEINFORMATION = 'MESSAGEINFORMATION';
  DISPID_GetNumber             = 2;
  fn_GETNUMBER          = 'GETRANDOMNUMBER';

// Метод GetIDsOfNames должен вернуть идентификаторы (DispID) для метода и
// именованных аргументов метода. В нашем случае в задачу метода входит определить
// обращение к имени и вернуть код ошибки для всех остальных имен:
function TMyClass.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount,
  LocaleID: Integer; DispIDs: Pointer): HResult;
type
 TDispIDsArray = array[0..0] of TDISPID;
 PDispIDsArray = ^TDispIDsArray;
var
 IDs: PDispIDsArray absolute DispIDs;
 i: integer;
 Name: WideString;
begin
 Result := S_OK;
 // Не поддерживаем именованные аргументы
 if NameCount > 1 then
    Result := DISP_E_UNKNOWNNAME
 else
    if NameCount < 1 then
       Result := E_INVALIDARG
    else
       Result := S_OK;

  for i := 0 to NameCount - 1 do
      IDs[i] := DISPID_UNKNOWN;

  if NameCount = 1 then
  begin
     Name := PWideChar(Names^);
     IDs[0] := 0;

     if UpperCase(Name) = fn_MESSAGEINFORMATION then
        IDs[0] := DISPID_MessageInformation;
     if UpperCase(Name) = fn_GERANDOMTNUMBER then
        IDs[0] := DISPID_GetRandomNumber;

     if IDs[0] = 0 then
        Result := DISP_E_UNKNOWNNAME;
  end;
end;

После чего сделаем реализаци метода Invoke, где и пропишем обработку:

function TMyClass.Invoke(DispID: Integer;
                         const IID: TGUID; LocaleID: Integer;
                         Flags: Word;
                         var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
var
  P: TDISPPARAMS absolute Params;
  ByIntRef1 : Integer;
  Err : HRESULT;
  ErrMethod : TErrMethodInfo;
  Str : String;
begin
  if DispId = 0 then begin
     OleVariant(VarResult^) := Self as IDispatch;
     Result := S_OK;
     Exit;
  end;
  case DispID of
       DISPID_MessageInformation :
        begin
          // Проверка на кол-во параметров
          if not CheckArgCount(P.cArgs, 1, ExcepInfo) then
          begin
             Result := DISP_E_EXCEPTION;
             Exit;
          end;
          // Аргументы в обратном порядке
          if IsVdalidTypeBSTR(P.rgvarg^[0])  then
          begin
             ShowMessage('Информация ' + #10#13 + TDispParams(P).rgvarg^[0].bstrval);
          end
          else
          begin
              SetErrorCheckParamsType(ExcepInfo, fn_MESSAGEINFORMATION);
              Result := DISP_E_EXCEPTION;
          end;
        end;
  end;
  Result := S_OK;
end;

Обратите внимание что пока реализован фактически только метод  MESSAGEINFORMATION. Пока так и задумано,   GETRANDOMNUMBER рассмотрим чуть позже.

Теперь сделаем VB-скрипт и запустим его с нашей программы. Маленькое примечание, т.к. при запуске Script Control требует имя функции которую нужно запустить в скрипте у нас она будет иметь имя main. Запуск скрипта будем производить так, текс скрипта берется из memo-поля:

procedure TForm1.BitBtn1Click(Sender: TObject);
var
 P : PSafeArray;
 SA : TSafeArrayBound;
begin
 ScriptControl.AddCode(Memo.Text);
 SA.cElements := 0;
 P := SafeArrayCreate(varVariant, 1, @SA);
 ScriptControl.Run('Main',P);
end;

Сам скрипт  для начала будет таким:

Sub Main()
   MyCLASS.MessageInformation("Проверка работы")
End Sub

Запускаем проверяем, вроде работает

Но не спешим радоваться, не все так гладко, есть и подводные камни:

Продолжение следует....

Далее в следующих частях: Проверка типов параметров; Преобразование типов параметров