IDispatch. GetIDsOfNames. Invoke. OLE Automation.

[Stilet]

В продолжении изучения диспатчей в OLE автоматике дошел до следующего этапа, это вызов методов.
Наскоро оформил его в класс для удобства портирования потом.

Прошу форумчан подсказать (если можно протестировать) чего я не учел еще в коде, который прикрепил во вложении.

Результат сего кода следующий:

Connected
Language True
UseSafeSubset True
AllowUI True
TimeOut True
Reset
Eval -2147024809 Операция успешно завершена.

Т.е. некорректно вызывается метод Eval с параметрами.
Хотя похоже что свойства устанавливаются.

Чего я не учел?

Заранее спасибо.

[Vapaamies]

Код оформлен не по правилам Borland, я такой читать не умею.

А вообще, не понял, зачем понадобился такой изврат. OLE, Automation и ActiveX были прозрачно вписаны в компилятор Delphi как раз ради того, чтобы свои велосипеды изобретать не приходилось. Какая изначальная задача решается?

[waleri]

GetIDsOfNames принято считать медленным вызовом.
В книгах рекомендуют за один вызов получить dispid всех нужных методов и потом использовать полученные коды.

Еще бросается в глаза заполнение DispParam - количество аргументов заполняем а сами аргументы - нет. Надо заполнять cArgs и rgvarg.

Вот эта строчка тоже несколько непоянтна:
DispParam.rgvarg^[i].bstrVal:=''

[Stilet]

зачем понадобился такой изврат.

Это увеличение функционала интерпретатора собственной разработки. Понятное дело что я бы в Делфи писал по-нормальному без копания вглубь. Но у меня есть свой ЯВУ, который я внедряю на предприятии, и большинство задач решаю именно с его помошью. Очередная задача - работать с сборками .NET, зарегистрированными как СОМ сервера. Сейчас это реализованно вызовами через VBS. Работать то работает, но от развития своего я не откажусь.
Вот такая вот изначальная задача - увеличить возможности нового ЯВУ.

GetIDsOfNames принято считать медленным вызовом.

Знаю. Этот код - тренировка. Сейчас вопрос о скорости не стоит.

Надо заполнять cArgs

87-я строка: DispParam.cArgs:=Length(aParams);

и rgvarg

101-113-е строки.
Дело в том что у меня есть параметр Item['Language']:='VBScript';
Вот чето на него не ругается. Не дает ошибку DISP_E_PARAMNOTFOUND
Но вызов самого метода с параметром неверный.
Но где....
Я и на StringToOleStr пока глаза закрываю, мне бы сейчас добиться понимания.

Вот эта строчка тоже несколько непоятна:

Да, это надо освобождать по нормальному, согласен. Это я потом обязательно учту.
Пока что меня интересует что это за ошибка такая, что мне попалась...

[Stilet]

Итак. Подведу итого того что удалось выяснить не спеша.

Код оформил в виде класса, который задействует интерфейс и его свойства, передаваемые в качестве строки. Мало ли - взбрендит в голову вводить через readln. Допустим есть задача - вычислить выражение. Выражение введенное в консоли. Оч. удобно будет применить интерфейс VBS для такого или Excell.
Конечно можно это и делать через обертки Делфи, а не через интерфейсы. Но вдруг нужно больше универсальности, тогда без этого не обойтись.

Код разобью на несколько постов. Каждый метод отдельным постом для удобства. Код прокомментирован.

Комментарии, критика, поправки будут приветствоваться.

Сам пример прикладываю в вложении. Там на Делфи DLL с тестовым OLE сервером (iTester.dll нужно будет скомпилировать), который нужно будет зарегистрировать в системе либо через regsvr32.exe либо средствами Делфи. Там же исходник (правда на Лазарусе), но помех его использования в Делфи быть не должно.

Описание класса:

 TAlisaOLE=class
private
 //Переменки для текста ошибки и названия метода-свойства
 Error,InvokedCommand:String;
 //массив параметров он же список аргументов (20 можно заменить на нужное кол-во, если покажется мало)
 aParams:Array[0..20] of variant;
 ArgsLen:Integer;//Переменка кол-ва аргументов, передаваемый в метод или свойство
 ExceptInfo: TExcepInfo; //Переемнка для информации по исключениям при ошибках
 ErrorCode:Integer; //Код ошибки
 ArgErr: Longint; //Кол-во ошибочных аргументов
 ResultOle:Variant; //Результат, что интерфейс вернет из функции или свойства
 //*****************************************************************************
 Disp:IDispatch; //Указатель на сам интерфейс типа IDispatch
 function GetItem(aPropName: String): Variant; //Получить значение свойства интерфейса
 procedure SetItem(aPropName: String; AValue: Variant); //Установить значение свойства интерфейса

 //Готовит аргументы для передачи в интерфейс
 Function PrepareArguments(var DispParam:TDispParams):Boolean;
public
 //Сеттер-геттер свойств из интерфейса. Сделано для удобства
 Property Item[aPropName:String]:Variant read GetItem write SetItem; default;
 //Функция перевода кода ошибки в читабельный текст
 Function ErrorCodeToString(aFuncName:String):String;
 //Вызов метода или свойства интерфейса
 // IsProperty ставится в True если работаем с свойством а не методом,PropPut в True если свойство нужно установить и false если считать
 Function InvokeMethod(aMethodName:WideString;IsProperty,PropPut:Boolean):Boolean;
 //Получение идентификатора свойства или метода
 Function GetIDByName(aMethodName:WideString):Integer;
 //Внесение аргумента в список аргументов
 Procedure AddArgument(Varvalue:Variant);
 //Получение (активация) интерфейса по имени класса или GUID
 Function GetObject(aName:String):Boolean; overload;
 Function GetObject(aGuid:TGUID):Boolean; overload;

  Constructor Create;
  Destructor Destroy;override;
end;

[Stilet]

//Функция разбора ошибок. Чтоб точно знать что пошло не так
//Возвращает текст ошибки и ее код в 10-ти и 16-ти ричной системе
function TAlisaOLE.ErrorCodeToString(aFuncName: String): String;
begin
 case ErrorCode of
  S_OK:                     begin Result:='';                                                 end;

  DISP_E_UNKNOWNNAME:       begin Result:='DISP_E_UNKNOWNNAME';                               end;
  DISP_E_UNKNOWNLCID:       begin Result:='DISP_E_UNKNOWNLCID';                               end;

  DISP_E_BADPARAMCOUNT:     begin Result:=('DISP_E_BADPARAMCOUNT');                           end;
  DISP_E_BADVARTYPE:        begin Result:=('DISP_E_BADVARTYPE');                              end;
  DISP_E_EXCEPTION:         begin Result:=('DISP_E_EXCEPTION ');                              end;
  DISP_E_MEMBERNOTFOUND:    begin Result:=('DISP_E_MEMBERNOTFOUND');                          end;
  DISP_E_NONAMEDARGS:       begin Result:=('DISP_E_NONAMEDARGS');                             end;
  DISP_E_OVERFLOW:          begin Result:=('DISP_E_OVERFLOW');                                end;
  DISP_E_PARAMNOTFOUND:     begin Result:=('DISP_E_PARAMNOTFOUND');                           end;
  DISP_E_TYPEMISMATCH:      begin Result:=('DISP_E_TYPEMISMATCH');                            end;
  DISP_E_UNKNOWNINTERFACE:  begin Result:=('DISP_E_UNKNOWNINTERFACE');                        end;
  DISP_E_PARAMNOTOPTIONAL:  begin Result:=('DISP_E_PARAMNOTOPTIONAL');                        end;


  E_ABORT:                  begin Result:='E_ABORT Operation aborted';                        end;
  E_ACCESSDENIED:           begin Result:='E_ACCESSDENIED General access denied error';       end;
  E_FAIL:                   begin Result:='E_FAIL Unspecified failure';                       end;
  E_HANDLE:                 begin Result:='E_HANDLE Handle that is not valid';                end;
  E_INVALIDARG:             begin Result:='E_INVALIDARG One or more arguments are not valid'; end;
  E_NOINTERFACE:            begin Result:='E_NOINTERFACE No such interface supported';        end;
  E_NOTIMPL:                begin Result:='E_NOTIMPL Not implemented';                        end;
  E_OUTOFMEMORY:            begin Result:='E_OUTOFMEMORY Failed to allocate necessary memory';end;
  E_POINTER:                begin Result:='E_POINTER Pointer that is not valid';              end;
  E_UNEXPECTED:             begin Result:='E_UNEXPECTED	Unexpected failure';                  end;

  else                      begin Result:='Unknown error code'   end;
 end;
 if Result<>'' then Result:=aFuncName+': '+Result+format(' (error code: %d - 0x%x)',[ErrorCode,ErrorCode]);
end;

[Stilet]

//Свойство для удобства вызывающее получение значений свойства  интерфейса по имени
function TAlisaOLE.GetItem(aPropName: String): Variant;
begin
 ResultOle:=InvokeMethod(aPropName,true,false);
end;

//Свойство для удобства вызывающее установку значений в свойство  интерфейса по имени
procedure TAlisaOLE.SetItem(aPropName: String; AValue: Variant);
begin
 AddArgument(AValue);
 ResultOle:=InvokeMethod(aPropName,true,true);
end;

[Stilet]

//Самая главная функция вызова метода по имени
//Она возвращает True если ошибок не было и False если что-то пошло не так
//Для анализа после в главной программе в условии типа IF
function TAlisaOLE.InvokeMethod(aMethodName: WideString; IsProperty,
  PropPut: Boolean): Boolean;
var
   aFlag:Word;   //Эта переменка будет указывать что мы вызываем
   //Либо это свойство (сеттер или геттер) ,либо функция

   DispPropertyPut: Integer;//Признаться не оч. понял зачем это поле,
   //но оно задействовано далее по ходу кода

 DispatchId: Integer;//Эта переменка будет получать идентификатор метода или свойства

 //А эта будет говорить интерфейсу что будет вызываться и сколько будет аргументов
 DispParam: TDispParams;

begin
  Error:='';
  //Предотвратим случай вызова, если инетрфейс не удалось активировать
  if Disp=nil then begin
    Error:='Dispatch cannot assigned';
    Result:=false;
    ErrorCode:=-1;
    exit;
  end;

  //Иначе запомним вызываемый метод для наших нужд
  InvokedCommand:=aMethodName;

  //Запросим его идентификатор (В данном примере запрос будет производиться
  //всегда перед вызовом метода, хотя это и понижает производительность и не рекомендуется
  //но я не стал заморачиваться с получением и запоминанием таблицы методов)
  //Такую оптимизацию оставляю на ваш суд
  DispatchId:=GetIDByName(aMethodName);
  //Если айдишник получить не удалось - дальше выполнение функции
  //продолжать бессмысленно
  if DispatchId<0  then    exit;

  DispPropertyPut:=0; //Эту переменную установим в ноль, предполагая что
  //вызываться будет метод. Если это не так - суть ниже по коду она будет переопределена

  DispParam.cArgs:=ArgsLen; //Укажем интерфейсу количество передаваемых ему аргументов
  //что хранит переменная  ArgsLen
  DispParam.cNamedArgs:=0;           //Об этих полях стоит почитать в MSDN.
  DispParam.rgdispidNamedArgs:=nil;  //Честно признаюсь не понял для чего они
  DispParam.rgvarg:=nil;  //Изначально проинициализируем список аргументов в nil
  //Это не обязательно, но без инициализации могут быть проблемы.
  //Про необходимость инициализации локальных переменных и чем чревато пренебрежение
  //инициализаци можете почитать в интернете

  //Если мы хотим работать с свойством
  if IsProperty then begin
    //Если мы его устанавливаем
    if PropPut then begin
      aFlag:=DISPATCH_PROPERTYPUT; //То укажем флажок  PROPERTYPUT
      DispPropertyPut:=DISPID_PROPERTYPUT;
      DispParam.rgdispidNamedArgs:=@DispPropertyPut;
      DispParam.cNamedArgs:=ArgsLen;  //И количество устанавлеваемых свойств
      //В нашем случае на один вызов - одно свойство
    end else aFlag:=DISPATCH_PROPERTYGET;  //Иначе будем считать что нужно
    //Получать значение свойства

    //Если же ни то ни другое - значит это вызов метода
  end else aFlag:=DISPATCH_METHOD or DISPATCH_PROPERTYGET;

  //Приготовим к вызову аргументы
  PrepareArguments(DispParam);

  //и произведем вызов метода-свойства в интерфейсе
  ErrorCode:=Disp.Invoke(
    DispatchId,            //Передав ему идентификатор свойства
    GUID_NULL,             //Про этот параметр почитайте в MSDN
    LOCALE_SYSTEM_DEFAULT, //Указав локаль по умолчанию от системы
    aFlag,                 //Передав тип вызываемого(сеттер, геттер, метод)
    DispParam,             //Передав список параметров
    @ResultOle,            //Переменку, куда будет выведен результат, если это геттер или функция
    @ExceptInfo,           //А так же переменку, куда будет выведена инфа в случае исключительной ситуации
    @ArgErr                //И переменку, что будет содержать кол-во ошибочных аргументов
  ); //Об этом подробнее расскажет MSDN

  //После освободим память, занятую ранее под аргументы
  FreeMem(DispParam.rgvarg, sizeof(TVariantArg) * ArgsLen);
  ArgsLen:=0;
  Result:=ErrorCode=0;
  //И проведем анализ ошибок, либо вывести текст ошибки либо пустую строку
  if not Result then
    Error:=ErrorCodeToString('Invoke');

end;

[Stilet]

//Эта функция готовит указанные нами агрументы для передачи методу интерфейса
// В нее передается специальная переменная типа TDispParams, которая и будет хранить
//значения и типы передаваемых аргуметов в метод или свойство
function TAlisaOLE.PrepareArguments(var DispParam: TDispParams): Boolean;
var i:integer;
begin
  if ArgsLen>0 then begin
     //Поскольку  TDispParams это указатель на массив агрументов
     //Запросим для него память в размере TVariantArg (это тип элемента этого массива)
     //Помноженном на количество агрументов
      GetMem(DispParam.rgvarg, sizeof(TVariantArg) * ArgsLen);
      //И для феншуя проинизиализируем их нулями. В данном случае не обязательно
      //Но желательно
      FillCHar(DispParam.rgvarg^, sizeof(TVariantArg) * ArgsLen, 0);

      //В цикле пересадим параметры в этот массив
      for i:=Low(aParams) to ArgsLen-1 do begin

         //Для очередного параметра укажем его тип.
         //Поскольку у нас параметры определены типом варианта
         //Можно использовать функции из модуля variants для этих дел
         //Тем паче что сам TVariantArg по сути тот же OleVariant
         DispParam.rgvarg^[i].vt := VarType(aParams[i]);

         //С типом все понятно, а вот со значением я ничего не придумал кроме как
         //Развести по отдельным полям его
         //Если это целое
         if VarIsOrdinal(aParams[i]) then   begin
           //То записать его в поле intVal
           DispParam.rgvarg^[i].intVal:=aParams[i];
         end else
         //Если вещественное
         if VarIsFloat(aParams[i]) then   begin
          //То в dblVal
          DispParam.rgvarg^[i].dblVal:=aParams[i];
         end else
         //А если строка
         if VarIsStr(aParams[i]) then   begin
            DispParam.rgvarg^[i].vt:=VT_BSTR;
            //То в bstrVal в виде указателя на двубайтную "широкую" строку
            //Указав ему принудительно тип BSTR. Хотя в ОЛЕ есть и дургие строковые типы
            //Пример будет использовать только его
            DispParam.rgvarg^[i].bstrVal:=PWideChar(Widestring(aParams[i]));
         end else
         ;
      end;
    end;

end;

[Stilet]

//Эта функция запрашивает уникальный ID метода или свойства в рамках OLE сервера
//Подсмотреть его можно в библиотеке типов кстати.
function TAlisaOLE.GetIDByName(aMethodName: WideString): Integer;
begin
  //Если мы интерфейс не получили, просто выйдем из функции с ошибкой
  //Это на случай когда нужно делать проверки
  if Disp=nil then begin
    Error:='GetIDsOfNames: Interface is nil';
    ErrorCode:=-1;
    exit;
  end;

 //Иначе попробуем запросить номер метода или свойства в интерфейсе
 //В данном пример используется локаль системы, я не рассматриваю сейчас
 //мультиязычные OLE
 ErrorCode:=Disp.GetIDsOfNames(GUID_NULL, @aMethodName, 1, LOCALE_SYSTEM_DEFAULT,@Result);
 //По необходимости заполним переменку текстом ошибки или оставим пустой
 Error:=ErrorCodeToString('GetIDsOfNames');


end;