OLE-шлюз

Evchic · Сообщение **Evchic** » Чт, 16/07/2009 16:17

Добрый день!
Скажите пожалуйста есть какой нибудь пример по использованию OLE шлюза на Delphi... откомпилировать пример из ASDK неполучается...

Screw · Сообщение **Screw** » Ср, 22/07/2009 14:18

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

Evchic · Сообщение **Evchic** » Чт, 23/07/2009 11:06

Вот это...

Код: Выделить всё

// вызовы объектных интерфейсов из предыдущего раздела
// описания интерфейсов получаются из tlb

program TestCOM;

uses activeX, sysutils, windows;

type

  IAtlantisAppSrv = interface(IDispatch)
    ['{13AAEF50-CE08-11D5-A27B-00204CE40998}']
    function  Connect(const uName: WideString; const uPass: WideString): HResult; stdcall;
    function  ExecVip(const Name: WideString; argc: Integer; var argv: OleVariant; 
                      out aRetVal: Integer): HResult; stdcall;
    function  LoadVip(const Name: WideString; out ifc: IDispatch): HResult; stdcall;
  end;

  IAtlantisAppSrvDisp = dispinterface
    ['{13AAEF50-CE08-11D5-A27B-00204CE40998}']
    procedure Connect(const uName: WideString; const uPass: WideString); dispid 100;
    function  ExecVip(const Name: WideString; argc: Integer; var argv: OleVariant): Integer; dispid 101;
    function  LoadVip(const Name: WideString): IDispatch; dispid 102;
  end;

  MainObj = interface(IUnknown)
    ['{9637AC80-F2EC-11D5-A2C6-00204CE40998}']
    function  TestFunc(p1: Integer; p2: Integer; out aRetVal: Integer): HResult; stdcall;
    function  TestProc(var p1: WideString; out aRetVal: WideString): HResult; stdcall;
    function  TestProc2(p1: Double; var p2: Double): HResult; stdcall;
    function  getComp(out aRetVal: Int64): HResult; stdcall;
    function  CompHandl(c1: Int64; var c2: Int64): HResult; stdcall;
    function  Get_TestProp(out aRetVal: WideString): HResult; stdcall;
    function  Set_TestProp(const aRetVal: WideString): HResult; stdcall;
    function  Get_TestProp2(out aRetVal: Integer): HResult; stdcall;
  end;

  MAINREC = packed record
    f1: Integer;
    f2: WideString;
    f3: Smallint;
  end;

  MainObj2 = interface(IUnknown)
    ['{B1A1C670-F3BF-11D5-A2C7-00204CE40998}']
    function  TestRec(var r: MAINREC): HResult; stdcall;
    function  TestRec2(r: MAINREC): HResult; stdcall;
  end;

  MainObj4 = interface;
  MainObj3 = interface(IUnknown)
    ['{B1A1C671-F3BF-11D5-A2C7-00204CE40998}']
    function  TestObjRef(out aRetVal: MainObj2): HResult; stdcall;
    function  TestVipRef(out aRetVal: IDispatch): HResult; stdcall;
    function  TestRef(out aRetVal: MainObj4): HResult; stdcall;
    function  TestCallRef(const ref: MainObj4; out aRetVal: Integer): HResult; stdcall;
  end;

  MainObj4 = interface(IUnknown)
    ['{B1A1C672-F3BF-11D5-A2C7-00204CE40998}']
    function  Test4(p1: Integer; p2: Integer; out aRetVal: Integer): HResult; stdcall;
  end;

  IAtlantisApp = IAtlantisAppSrv;
  IAtlantisIfc = IDispatch;

const IID_IAtlantisAppSrv  : TIID = '{13AAEF50-CE08-11d5-A27B-00204CE40998}';
const CLSID_AtlantisAppSrv : TIID = '{2C4CF260-DAA2-11d5-A29D-00204CE40998}';
const LIBID_DebugLib : TGUID = '{9637AC81-F2EC-11D5-A2C6-00204CE40998}';
const IID_MainObj    : TGUID = '{9637AC80-F2EC-11D5-A2C6-00204CE40998}';
const IID_MainObj2   : TGUID = '{B1A1C670-F3BF-11D5-A2C7-00204CE40998}';
const IID_MainObj3   : TGUID = '{B1A1C671-F3BF-11D5-A2C7-00204CE40998}';
const IID_MainObj4   : TGUID = '{B1A1C672-F3BF-11D5-A2C7-00204CE40998}';

var
  hr : HRESULT;
  pIAtlantisApp : IAtlantisApp;
  pIAtlantisIfc : IAtlantisIfc;
  vPar : WideString;
  p : OleVariant;
  ret : longint;
  pMainObj : MainObj;
  pMainObj2 : MainObj2;
  pMainObj3 : MainObj3;
  pMainObj4 : MainObj4;
  d : double;
  s : WideString;
  c1,c2 : int64;
  rec : MAINREC;

label quit;

begin
 pIAtlantisApp := nil;
 pIAtlantisIfc := nil;
 hr := CoInitialize (nil);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;

 hr := CoCreateInstance (CLSID_AtlantisAppSrv,
                         nil, CLSCTX_LOCAL_SERVER,
                         IID_IAtlantisAppSrv,
                         pIAtlantisApp);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;

 hr := pIAtlantisApp.Connect ('aa','aa');
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;

 p := 5;
 hr := pIAtlantisApp.ExecVip ('aTestVip',1,p,ret);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;
 WriteLn ('Result = ',ret);

 hr := pIAtlantisApp.LoadVip ('aTestVip',pIAtlantisIfc);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;

 hr := pIAtlantisIfc.QueryInterface (IID_MainObj,pMainObj);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;

 hr := pMainObj.TestFunc (2,5,ret);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;
 writeln ('result = ', ret);

 s := 'QQ';
 hr := pMainObj.TestProc (s,vPar);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;
 writeln ('result = ', vPar, '; ', s);

 hr := pMainObj.TestProc2 (2.5,d);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;
 writeln ('result = ', d);

 hr := pMainObj.get_TestProp (vPar);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;
 writeln ('result = ', vPar);

 hr := pMainObj.set_TestProp (vPar);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;

 hr := pMainObj.get_TestProp2 (ret);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;
 writeln ('result = ', ret);

 hr := pMainObj.getComp (c1);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;
 writeln ('result = ', c1);

 c1 := 12;
 c2 := 17;
 hr := pMainObj.CompHandl (c1,c2);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;
 writeln ('result = ', c2);

 hr := pIAtlantisIfc.QueryInterface (IID_MainObj3,pMainObj3);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;

 hr := pMainObj3.TestObjRef (pMainObj2);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;

 rec.f1 := 5;
 rec.f2 := 'record';
 rec.f3 := 7;
 hr := pMainObj2.TestRec (rec);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;

 hr := pMainObj2.TestRec2 (rec);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;

 hr := pMainObj3.TestRef (pMainObj4);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;

 hr := pMainObj4.Test4 (1,2,ret);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;
 writeln ('result = ', ret);

 hr := pMainObj3.TestCallRef (pMainObj4,ret);
 WriteLn (intToHex (hr,8));
 if hr <> 0 then goto quit;
 writeln ('result = ', ret);

quit : 
 pMainObj      := nil;
 pMainObj2     := nil;
 pMainObj3     := nil;
 pMainObj4     := nil;
 pIAtlantisIfc := nil;
 pIAtlantisApp := nil;
 CoUninitialize;
end.

Все умирает вот здесь

Код: Выделить всё

 hr := CoCreateInstance (CLSID_AtlantisAppSrv,
                         nil, CLSCTX_LOCAL_SERVER,
                         IID_IAtlantisAppSrv,
                         pIAtlantisApp);

Evchic · Сообщение **Evchic** » Чт, 23/07/2009 11:06

Этого в реестре нет
const IID_IAtlantisAppSrv : TIID = '{13AAEF50-CE08-11d5-A27B-00204CE40998}';

Это в реестре есть
const CLSID_AtlantisAppSrv : TIID = '{2C4CF260-DAA2-11d5-A29D-00204CE40998}';

Screw · Сообщение **Screw** » Вт, 28/07/2009 18:01

Интерфейс в реестре и не нужен.
Предложенный пример собирается и работает. Правда вот сервис у меня пока не захотел стартовать - пытается раскочегариться в течение 2-х минут (CoCreateInstance), после чего отваливается, и управление возвращается в тестовую программу. Код возврата - CO_E_SERVER_EXEC_FAILURE (0x80080005). Пытаюсь выяснить, что не так с сервисом. О результатах сообщу отдельно.

Evchic · Сообщение **Evchic** » Ср, 29/07/2009 10:20

Screw писал(а):Интерфейс в реестре и не нужен.
Предложенный пример собирается и работает. Правда вот сервис у меня пока не захотел стартовать - пытается раскочегариться в течение 2-х минут (CoCreateInstance), после чего отваливается, и управление возвращается в тестовую программу. Код возврата - CO_E_SERVER_EXEC_FAILURE (0x80080005). Пытаюсь выяснить, что не так с сервисом. О результатах сообщу отдельно.

Вот таже ситуация и у меня получилась

Screw · Сообщение **Screw** » Чт, 30/07/2009 18:30

Помогла правильная настройка сервера и клиента. Ниже приведены существенные для данной ситуации значения ключей реестра.

Для клиента:

Код: Выделить всё

[HKEY_LOCAL_MACHINE\SOFTWARE\Galaktika Corp\Client]
"Protocol"="comdrv.dll"

Для сервера:

Код: Выделить всё

[HKEY_LOCAL_MACHINE\SOFTWARE\Galaktika Corp\Server]
"Protocols"="comdrv.dll"
"ReceiverProtocol"=dword:00000000

Упомянутых в примере тестовых интерфесов у меня нет, поэтому его нормальное выполнение завершилось на вызове

Код: Выделить всё

hr := pIAtlantisApp.ExecVip ('aTestVip',1,p,ret);

Evchic · Сообщение **Evchic** » Пт, 31/07/2009 09:16

А можете привести полный список параметров для веткот
[HKEY_LOCAL_MACHINE\SOFTWARE\Galaktika Corp\Client]
[HKEY_LOCAL_MACHINE\SOFTWARE\Galaktika Corp\Server]

Я сделал "Protocol"="comdrv.dll"
но по прежнему Код возврата - CO_E_SERVER_EXEC_FAILURE (0x80080005)

При выполнении

Код: Выделить всё

 hr := CoCreateInstance (CLSID_AtlantisAppSrv,
                         nil, CLSCTX_LOCAL_SERVER,
                         IID_IAtlantisAppSrv,
                         pIAtlantisApp);

запускается galsrv.exe на 1-2 секунды и закрывается передавая управления основной проге... и pIAtlantisApp остается равным nil

cruger · Сообщение **cruger** » Пт, 31/07/2009 09:20

Сдаётся мне, то, что Вы хотите сделать, надо делать через обычного клиента, а не через сервер.

Evchic · Сообщение **Evchic** » Пт, 31/07/2009 09:47

Да можно было бы через обычный Atlexec.app сделать...

Код: Выделить всё

 // Инициализация OLE
  Iface:= CreateOleObject('Atlexec.app');
  My:= Iface.LoadVip('Utils::Users');
 // Функция передачи пути на файл
  My.test('.....');  // ваш поток
  //Выгрузка OLE
  My:= UnAssigned;
  Iface:= UnAssigned;

но напригает то факт что происходит отображения картинки галактики....

Screw · Сообщение **Screw** » Пт, 31/07/2009 11:07

Ну разумеется!
Регистрируем pxcomdrv.dll:

Код: Выделить всё

regsvr32 pxcomdrv.dll

larin · Сообщение **larin** » Пт, 31/07/2009 11:22

Evchic писал(а): но напригает то факт что происходит отображения картинки галактики....

удалите GalNet.bmp из папки EXE галактики

Evchic · Сообщение **Evchic** » Пт, 31/07/2009 11:46

Screw писал(а):Ну разумеется!
Регистрируем pxcomdrv.dll:
Код: Выделить всё
regsvr32 pxcomdrv.dll

Огромное спасибо все получилось

Неплохо было бы это в документацию добавить!!!

Evchic · Сообщение **Evchic** » Ср, 02/09/2009 13:56

Виталий Корзюк

Подскажите вчем может проблема

имею

Код: Выделить всё

unit Gal_COM;
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. 
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}
{$VARPROPSETTER ON}

interface

uses
  activeX,Windows, Messages, SysUtils, Variants, Classes, StdVCL, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  IAtlantisAppSrv = interface(IDispatch)
    ['{13AAEF50-CE08-11D5-A27B-00204CE40998}']
    function  Connect(const uName: WideString; const uPass: WideString): HResult; stdcall;
    function  ExecVip(const Name: WideString; argc: Integer; var argv: OleVariant;
                      out aRetVal: Integer): HResult; stdcall;
    function  LoadVip(const Name: WideString; out ifc: IDispatch): HResult; stdcall;
  end;

  IAtlantisAppSrvDisp = dispinterface
    ['{13AAEF50-CE08-11D5-A27B-00204CE40998}']
    procedure Connect(const uName: WideString; const uPass: WideString); dispid 100;
    function  ExecVip(const Name: WideString; argc: Integer; var argv: OleVariant): Integer; dispid 101;
    function  LoadVip(const Name: WideString): IDispatch; dispid 102;
  end;

  IUsers = interface(IUnknown)
    ['{CA477FE3-A426-4F3E-949E-8EDF6725F4EB}']
    function GhostMethod_IUsers_0_1: HResult; stdcall;
    function GhostMethod_IUsers_4_2: HResult; stdcall;
    function GhostMethod_IUsers_8_3: HResult; stdcall;
    function SendMessageToActiveUsers(const msg: WideString): HResult; stdcall;
  end;

  IAtlantisApp = IAtlantisAppSrv;
  IAtlantisIfc = IDispatch;
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

const IID_IAtlantisAppSrv  : TIID = '{13AAEF50-CE08-11d5-A27B-00204CE40998}';
const CLSID_AtlantisAppSrv : TIID = '{2C4CF260-DAA2-11d5-A29D-00204CE40998}';
const LIBID_FULLLib: TGUID = '{BBB198A1-11BF-42B0-A066-B9D80B6DC746}';
const IID_IUsers: TGUID = '{CA477FE3-A426-4F3E-949E-8EDF6725F4EB}';


var
  Form1: TForm1;
  hr : HRESULT;
  pIAtlantisApp : IAtlantisApp;
  pIAtlantisIfc : IAtlantisIfc;
  vPar : Integer;
  p : OleVariant;
  ret : longint;
  pMainObj : IUsers;
  d : double;
  s : WideString;
  c1,c2 : int64;


implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
 pIAtlantisApp := nil;
 pIAtlantisIfc := nil;
 //pMainObj := nil;
 hr := CoInitialize (nil);
 if hr <> 0 then ShowMessage ('Ev1   '+intToHex (hr,8));


 hr := CoCreateInstance (CLSID_AtlantisAppSrv,
                         nil, CLSCTX_LOCAL_SERVER,
                         IID_IAtlantisAppSrv,
                         pIAtlantisApp);

 ShowMessage  (intToHex(CO_E_SERVER_EXEC_FAILURE,8)+'  Ev2   '+intToHex (hr,8));

 hr := pIAtlantisApp.Connect ('aa','aa');

ShowMessage ('Ev3   '+intToHex (hr,8));
 p := 5;
 hr := pIAtlantisApp.LoadVip ('UTILS::Users',pIAtlantisIfc);
  ShowMessage  ('Ev4   '+intToHex (hr,8));
 hr := pIAtlantisIfc.QueryInterface (IID_IUsers,pMainObj);
 ShowMessage  ('Ev5   '+intToHex (hr,8));
 s := 'QQ';
 hr := pMainObj.SendMessageToActiveUsers(s);
 ShowMessage  ('Ev6   '+intToHex (hr,8));
end;
end.

получаю ошибку

---------------------------
Gal_com_prj
---------------------------
Access violation at address 00000000. Read of address 00000000.
---------------------------
ОК
---------------------------

вот в этом месте

Код: Выделить всё

 hr := pMainObj.SendMessageToActiveUsers(s);

Screw · Сообщение **Screw** » Чт, 03/09/2009 16:09

А кто такой IUsers?

OLE-шлюз

OLE-шлюз

Вход • Регистрация