OLE шлюз

[evchic]

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

имею

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

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);

[SNET]

Dim GalApp As Variant, Str As Variant

В топку вариантные переменные. Автор, наверное, уже забыл про свой топик ввиду давности времени, но зачем он использовал позднее связывание? Использовал бы ранее (в случае упомянутого .Net - интероп-обертку) - получил бы строгую типизацию и отсутствие проблем с типами параметров.

[KATZ]

Hmurii

только дело не доходит до анализа содержимого в переданном параметре так как система отказывается принимать этот параметр со словами COMException "несовпадение типов"

Вообще-то у интерфейса ObjRem еще своих два параметра. Вот так попробуйте:

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

Dim GalApp, RetValue, Par1, Par2 As Variant
Set GalApp = CreateObject("AtlExec.App")
Par1 = 0
Par2 = 1
RetValue = GalApp.ExecVip("L_Remont::ObjRem", Par1, Par2)

evchic
А что за интерфейс UTILS::Users, самодельный что ли? В "Галактике" вроде нет такого. А сообщение такое будет, если QueryInterface вернул pMainObj==0, либо если метод SendMessageToActiveUsers оказался не определен (т. е. с нулевым адресом).

[evchic]

это собственный фейс...
Сделал из реса при помощи AtlIDL сделал файл FULL.idl

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

//
//
//
import "unknwn.idl", "oaidl.idl";
//
//
//
[
   object,
   uuid(CA477FE3-A426-4F3E-949E-8EDF6725F4EB),
   version (1.0),
   pointer_default(unique)
]
interface IUsers : IUnknown
{
   HRESULT SendMessageToActiveUsers ([in] BSTR msg);
};
//
//
//
[
   uuid(BBB198A1-11BF-42B0-A066-B9D80B6DC746),
   version (1.0)
]
library FULLLib
{
   interface IUsers;
};

из него FULLProxy.dll отправил в католог exe галактики
FULLProxy.dll зарегестрировал в системе
файл AtlGUID.txt отправил в католог exe галактики

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

;
; VipInterface UTILS::Users
;
UTILS::IUsers -965546004 {CA477FE3-A426-4F3E-949E-8EDF6725F4EB}
;
; library
FULLLib 0 {BBB198A1-11BF-42B0-A066-B9D80B6DC746}
;