DCOM tovejs kommunikation

Kan du ikke bruge server/klient socklet og så kontakte klienten via IPén????

Du mener bruge sockets? Joohh, men jeg vil nu helst bruge DCOM.

Er det ikke klienterne der kontakter serveren? Så kan du vel bare svare dem. Ellers er det vel noget med at lave en slags letvægts server på klienterne som du kan kalde metoder på?

her er en ultra simpel måde at gøre det på
Jeg har i serverens typelibrary lavet et interface der hedder ICallBack med een function der hedder RecvMessage.
Clienten opretter en classe der arver fra TAutoIntfObject, og implementerer ICallBack. Denne Klasses recvMessage trigger et event der er forbundet med en metode på clientens form med samme signatur. Desuden skal du bruge en
function på serveren der tager en parameter af typen ICallBack med sig. Når du så har lyst til at sende en besked til clienten kalder du ICallBack\'s RecvMessage

Server:

unit TestImpl;

interface

uses
  ComObj, ActiveX, TestServer_TLB;

type
  TTest = class(TAutoObject, ITest)
  private
    FCallBack: ICallBack;
  protected
    procedure Connect(const CallBack: ICallBack); safecall;
    procedure SendMessage(const Msg: WideString); safecall;
  end;

implementation

uses ComServ, ServerMain;

procedure TTest.Connect(const CallBack: ICallBack);
begin
  FCallBack := CallBack;
end;

procedure TTest.SendMessage(const Msg: WideString);
begin
  Form1.Edit1.Text := \'Server received message: \' + Msg;

  if Assigned(FCallBack) then
    FCallBack.RecvMessage(\'acknowleged\');
end;

initialization
  TAutoObjectFactory.Create(ComServer, TTest, Class_Test,
    ciMultiInstance, tmApartment);
end.

--------------------------------------------------------

og clienten:

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, TestServer_TLB, ComObj, ActiveX;

type
  TForm1 = class(TForm)
    btnConnect: TButton;
    btnSend: TButton;
    edtSend: TEdit;
    edtRecv: TEdit;
    procedure btnConnectClick(Sender: TObject);
    procedure btnSendClick(Sender: TObject);
  private
    FTest: ITest;
    procedure RecvMessage(const Msg: string);
  public
    { Public declarations }
  end;

  TMessageEvent = procedure (const Msg: string) of object;

  TMyEvent = class(TAutoIntfObject, ICallBack)
  private
    FOnMessage: TMessageEvent;
  protected
    procedure RecvMessage(const Msg: WideString); safecall;
  public
    constructor Create;
    property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{ TMyEvent }

constructor TMyEvent.Create;
var
  ifTypeLib: ITypeLib;
begin
  OleCheck(LoadRegTypeLib(LIBID_TestServer, 1, 0, 0, ifTypeLib));
  inherited Create(ifTypeLib, ICallBack);

  _AddRef;
end;

procedure TMyEvent.RecvMessage(const Msg: WideString);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Msg);
end;

{ TForm1 }

procedure TForm1.RecvMessage(const Msg: string);
begin
  edtRecv.Text := Msg;
end;
procedure TForm1.btnConnectClick(Sender: TObject);
var
  E: TMyEvent;
begin
  E := TMyEvent.Create;
  E.OnMessage := RecvMessage;
  FTest := CoTest.Create;
  FTest.Connect(E);
end;

procedure TForm1.btnSendClick(Sender: TObject);
begin
  FTest.SendMessage(edtSend.Text);
end;

Kanooon. God løsning. Det var noget i den retning jeg havde tænkt, men det her er virkelig pæn kode.

tak - det kan dog laves på en endnu smartere måde

Fortæl endelig... Jeg har flere point :-)

Jeg har udvidet eksemplet lidt, så det er blevet starten på et chat program. Jeg har lavet lidt om på hvordan eventinterfacet håndteres, ved brug af en TConnectionPointContainer, hvor man kan registrere et interface, og klassen returnerer en liste med alle instanser af dettte interface. Dvs. en client kan vælge om han vil sende beskeden til alle clienter, eller om det kun er en bestemt klient der skal modtage beskeden. Desuden har jeg tilføjet et event der kaldes når en client logger af eller på, så clienterne kan opdatere deres liste med online brugere. håber du kan bruge det.

TypeLibrary:

unit MsgServer_TLB;

interface

uses Windows, ActiveX, Classes, Graphics, OleCtrls, StdVCL;

const
  LIBID_MsgServer: TGUID = \'{F2F16466-96B8-42D6-9465-2C9248805058}\';
  IID_ISession: TGUID = \'{C39C3E82-22ED-4A11-BA4C-C9D76C24CD73}\';
  CLASS_Session: TGUID = \'{C6ED78A9-E009-4E17-8731-EB83E5500005}\';
  IID_IClient: TGUID = \'{47201459-B14C-412B-B5B1-24E95F7F40A1}\';
  CLASS_Client: TGUID = \'{2B12A4B8-6C25-453F-A612-73095BBA3A6F}\';
  IID_IConnection: TGUID = \'{C07BF430-CC73-4649-A3E2-AEBCB6EC878A}\';
type

  ISession = interface;
  ISessionDisp = dispinterface;
  IClient = interface;
  IClientDisp = dispinterface;
  IConnection = interface;
  IConnectionDisp = dispinterface;

  Session = ISession;
  Client = IClient;

  ISession = interface(IDispatch)
    [\'{C39C3E82-22ED-4A11-BA4C-C9D76C24CD73}\']
    function ConnectClient(const Connection: IConnection): WordBool; safecall;
    function DisconnectClient(const Connection: IConnection): WordBool; safecall;
    procedure SendGlobal(const Connection: IConnection; const Message: WideString); safecall;
    procedure SendSpecial(const Connection: IConnection; RecvID: Integer; const Message: WideString); safecall;
  end;

  ISessionDisp = dispinterface
    [\'{C39C3E82-22ED-4A11-BA4C-C9D76C24CD73}\']
    function ConnectClient(const Connection: IConnection): WordBool; dispid 1;
    function DisconnectClient(const Connection: IConnection): WordBool; dispid 2;
    procedure SendGlobal(const Connection: IConnection; const Message: WideString); dispid 3;
    procedure SendSpecial(const Connection: IConnection; RecvID: Integer; const Message: WideString); dispid 5;
  end;

  IClient = interface(IDispatch)
    [\'{47201459-B14C-412B-B5B1-24E95F7F40A1}\']
    procedure SendMessage(const Connection: IConnection; ID: Integer; const Message: WideString); safecall;
    procedure Connect(const Connection: IConnection); safecall;
    procedure Disconnect(const Connection: IConnection); safecall;
  end;

  IClientDisp = dispinterface
    [\'{47201459-B14C-412B-B5B1-24E95F7F40A1}\']
    procedure SendMessage(const Connection: IConnection; ID: Integer; const Message: WideString); dispid 5;
    procedure Connect(const Connection: IConnection); dispid 2;
    procedure Disconnect(const Connection: IConnection); dispid 3;
  end;

  IConnection = interface(IDispatch)
    [\'{C07BF430-CC73-4649-A3E2-AEBCB6EC878A}\']
    function Get_UserName: WideString; safecall;
    procedure Set_UserName(const Value: WideString); safecall;
    function Get_ID: Integer; safecall;
    procedure Set_ID(Value: Integer); safecall;
    procedure RecvMessage(const Sender: WideString; const Message: WideString); safecall;
    procedure ClientsOnline(Clients: OleVariant); safecall;
    property UserName: WideString read Get_UserName write Set_UserName;
    property ID: Integer read Get_ID write Set_ID;
  end;

  IConnectionDisp = dispinterface
    [\'{C07BF430-CC73-4649-A3E2-AEBCB6EC878A}\']
    property UserName: WideString dispid 1;
    property ID: Integer dispid 2;
    procedure RecvMessage(const Sender: WideString; const Message: WideString); dispid 3;
    procedure ClientsOnline(Clients: OleVariant); dispid 4;
  end;

  CoSession = class
    class function Create: ISession;
    class function CreateRemote(const MachineName: string): ISession;
  end;

  CoClient = class
    class function Create: IClient;
    class function CreateRemote(const MachineName: string): IClient;
  end;

implementation

uses ComObj;

class function CoSession.Create: ISession;
begin
  Result := CreateComObject(CLASS_Session) as ISession;
end;

class function CoSession.CreateRemote(const MachineName: string): ISession;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_Session) as ISession;
end;

class function CoClient.Create: IClient;
begin
  Result := CreateComObject(CLASS_Client) as IClient;
end;

class function CoClient.CreateRemote(const MachineName: string): IClient;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_Client) as IClient;
end;

--------------------------------------------------------

Globals:

unit Globals;

interface

uses
  Classes;

type
  TClientInfo = record
    Name: string[30];
    ID: Integer;
  end;

  PClients = ^TClients;
  TClients = record
    Info: array[1..100] of TClientInfo;
    Count: Integer;
  end;

  procedure VariantToStrings(V: Variant; Items: TStrings);

implementation

procedure VariantToStrings(V: Variant; Items: TStrings);
var
  Clients: TClients;
  Ptr: PClients;
  i: Integer;
  Info: TClientInfo;
begin
  //standard metode til at flytte data fra en variant til en pascal datastruktur
  Ptr := VarArrayLock(V);
  try
    Move(Ptr^, Clients, SizeOf(TClients));
  finally
    VarArrayUnlock(V);
  end;

  for i := 1 to Clients.Count do
  begin
    Info := Clients.Info[i];
    //hver clients navn og id gemmes i listen
    Items.AddObject(Info.Name, Pointer(Info.ID));
  end;
end;

end.

--------------------------------------------------------

SessionImpl:

unit SessionImpl;

interface

uses
  ComObj, ActiveX, AxCtrls, MsgServer_TLB;

type
  TSession = class(TAutoObject, IConnectionPointContainer, ISession)
  private
    //container med alle eventsinktyper - i dette eksempel er der kun een
    FConnectionPoints: TConnectionPoints;
    //liste med alle eventsinks af en bestemt type (IConnection)
    FSinks: TConnectionPoint;
    procedure ClientsToVariant(var V: OleVariant);
    procedure NotifyClients;
  protected
    function ConnectClient(const Connection: IConnection): WordBool; safecall;
    function DisconnectClient(const Connection: IConnection): WordBool;
      safecall;
    procedure SendGlobal(const Connection: IConnection;
      const Message: WideString); safecall;
    procedure SendSpecial(const Connection: IConnection; RecvID: Integer;
      const Message: WideString); safecall;
  public
    procedure Initialize; override;
    destructor Destroy; override;
    property ConnectionPoints: TConnectionPoints read FConnectionPoints
      write FConnectionPoints implements IconnectionPointContainer;
  end;

const
  Session: ISession = nil;

implementation

uses
  Windows, ComServ, Globals, ServerMain;

{ TSession }

procedure TSession.Initialize;
begin
  inherited Initialize;
  FConnectionPoints := TConnectionPoints.Create(Self);
  FSinks := FConnectionPoints.CreateConnectionPoint(IConnection, ckMulti, nil);
end;

destructor TSession.Destroy;
begin
  FSinks.Free;
  FConnectionPoints.Free;
  inherited Destroy;
end;

procedure TSession.ClientsToVariant(var V: OleVariant);
var
  EnumConns: IEnumConnections;
  ConnectData: TConnectData;
  Conn: IConnection;
  Fetched: Longint;
  Count: Integer;
  Data: TClients;
  PData: PClients;
begin
  Count := 0;
  OleCheck((FSinks as IConnectionPoint).EnumConnections(EnumConns));
  //alle eventsinksne løbes igennem, og navn og id gemmes i recorden
  while EnumConns.Next(1, ConnectData, @Fetched) = S_OK do
    try
      Inc(Count);
      Conn := ConnectData.pUnk as IConnection;
      Data.Info[Count].Name := Conn.UserName;
      Data.Info[Count].ID  := Conn.ID;
      ConnectData.pUnk := nil;
    except
      //ignorer exceptions
    end;

  Data.Count := Count;

  //recordens data flyttes over i en variant
  V := VarArrayCreate([1, SizeOf(TClients)], VarByte);
  PData := VarArrayLock(V);
  try
    Move(Data, PData^, SizeOf(TClients));
  finally
    VarArrayUnlock(V);
  end;
end;

procedure TSession.NotifyClients;
var
  Clients: OleVariant;
  EnumConns: IEnumConnections;
  ConnectData: TConnectData;
  Fetched: Longint;
begin
  ClientsToVariant(Clients);

  OleCheck((FSinks as IConnectionPoint).EnumConnections(EnumConns));
  //hver client modtager en variant med navn og id på alle clienter via eventen
  //dette kunne laves mere effektivt da det kun er clienten selv der har brug
  //for alle navnene, de andre skal kun denne clients info, og om han logger af eller på
  while EnumConns.Next(1, ConnectData, @Fetched) = S_OK do
    try
      (ConnectData.pUnk as IConnection).ClientsOnline(Clients);
      ConnectData.pUnk := nil;
    except
      //ignorer exceptions
    end;

  //listboxen på serverformen opdateres
  ServerForm.UpdateClientList(Clients);
end;

function TSession.ConnectClient(const Connection: IConnection): WordBool;
var
  CPC: IConnectionPointContainer;
  CP: IConnectionPoint;
  ID: Integer;
  hr: HResult;
begin
  GetInterface(IConnectionPointContainer, CPC);

  //finder listen med de ønskede eventsinks
  hr := CPC.FindConnectionPoint(IConnection, CP);

  if SUCCEEDED(hr) then
    //den nye client tilføjes
    hr := CP.Advise(Connection as IUnknown, ID);

  if SUCCEEDED(hr) then
    Connection.ID := ID;

  //alle clienter for besked om at en ny client er logget på
  NotifyClients;

  Result := SUCCEEDED(hr);
end;

function TSession.DisconnectClient(const Connection: IConnection): WordBool;
var
  CPC: IConnectionPointContainer;
  CP: IConnectionPoint;
  hr: HResult;
begin
  GetInterface(IConnectionPointContainer, CPC);

  hr := CPC.FindConnectionPoint(IConnection, CP);

  if SUCCEEDED(hr) then
    //client fjernes
    hr := CP.Unadvise(Connection.ID);

  NotifyClients;

  Result := SUCCEEDED(hr);
end;

procedure TSession.SendGlobal(const Connection: IConnection;
  const Message: WideString);
var
  EnumConns: IEnumConnections;
  ConnectData: TConnectData;
  Fetched: Longint;
begin
  //beskeden sendes til alle clineter
  OleCheck((FSinks as IConnectionPoint).EnumConnections(EnumConns));
  while EnumConns.Next(1, ConnectData, @Fetched) = S_OK do
    try
      (ConnectData.pUnk as IConnection).RecvMessage(Connection.UserName, Message);
      ConnectData.pUnk := nil;
    except
      //ignorer exceptions
    end;
end;

procedure TSession.SendSpecial(const Connection: IConnection;
  RecvID: Integer; const Message: WideString);
var
  EnumConns: IEnumConnections;
  ConnectData: TConnectData;
  Conn: IConnection;
  Fetched: Longint;
begin
  //beskeden sendes kun til client med RecvID
  OleCheck((FSinks as IConnectionPoint).EnumConnections(EnumConns));
  while EnumConns.Next(1, ConnectData, @Fetched) = S_OK do
    try
      Conn := ConnectData.pUnk as IConnection;
      if Conn.ID = RecvID then
        Conn.RecvMessage(Connection.UserName, Message);
      ConnectData.pUnk := nil;
    except
      //ignorer exceptions
    end;
end;

initialization
  TAutoObjectFactory.Create(ComServer, TSession, Class_Session,
    ciMultiInstance, tmApartment);
end.

--------------------------------------------------------

ClientImpl:

unit ClientImpl;

interface

uses
  ComObj, ActiveX, MsgServer_TLB;

type
  TClient = class(TAutoObject, IClient)
  protected
    procedure SendMessage(const Connection: IConnection; ID: Integer;
      const Message: WideString); safecall;
    procedure Connect(const Connection: IConnection); safecall;
    procedure Disconnect(const Connection: IConnection); safecall;
  end;

const
  ConnCount: Integer = 0;

implementation

uses
  ComServ, SessionImpl;

{ TClient }

procedure TClient.SendMessage(const Connection: IConnection; ID: Integer;
  const Message: WideString);
begin
  if Assigned(Session) then
  begin
    if ID <= 0 then //hvis id er 0 sendes beskeden til alle
      Session.SendGlobal(Connection, Message)
    else            //ellers er der en bestemt modtager
      Session.SendSpecial(Connection, ID, Message);
  end;
end;

procedure TClient.Connect(const Connection: IConnection);
begin
  //hvis det er den første client der logger på oprettes sessionen
  if not Assigned(Session) then
    Session := TSession.Create;

  //kaldet viderestilles
  Session.ConnectClient(Connection);
  Inc(ConnCount);
end;

procedure TClient.Disconnect(const Connection: IConnection);
begin
  if not Assigned(Session) then Exit;

  Session.DisconnectClient(Connection);
  Dec(ConnCount);

  //hvis det er den sidste client der logger af frigøres sessionen
  if ConnCount <= 0 then
    Session := nil;
end;

initialization
  TAutoObjectFactory.Create(ComServer, TClient, Class_Client,
    ciMultiInstance, tmApartment);
end.


--------------------------------------------------------

ConnImpl:

unit ConnImpl;

interface

uses
  MsgServer_TLB, ComObj;

type
  TMessageEvent = procedure (const Sender, Message: string) of object;

  TClientListChange = procedure (Clients: OleVariant) of object;

  TConnection = class(TAutoIntfObject, IConnection)
  private
    FUserName: string;
    FID: Integer;
    FOnMessage: TMessageEvent;
    FOnClientListChange: TClientListChange;
  protected
    function Get_UserName: WideString; safecall;
    procedure Set_UserName(const Value: WideString); safecall;
    function Get_ID: Integer; safecall;
    procedure Set_ID(Value: Integer); safecall;
    procedure RecvMessage(const Sender, Message: WideString); safecall;
    procedure ClientsOnline(Clients: OleVariant); safecall;
  public
    constructor Create;
    property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
    property OnClientListChange: TClientListChange read FOnClientListChange
      write FOnClientListChange;
  end;

implementation

uses
  ActiveX;

{ TConnection }

constructor TConnection.Create;
var
  ifTypeLib: ITypeLib;
begin
  OleCheck(LoadRegTypeLib(LIBID_MsgServer, 1, 0, 0, ifTypeLib));
  inherited Create(ifTypeLib, IConnection);

  _AddRef;
end;

function TConnection.Get_UserName: WideString;
begin
  Result := FUserName;
end;

procedure TConnection.Set_UserName(const Value: WideString);
begin
  FUserName := Value;
end;

function TConnection.Get_ID: Integer;
begin
  Result := FID
end;

procedure TConnection.Set_ID(Value: Integer);
begin
  FID := Value;
end;

procedure TConnection.RecvMessage(const Sender, Message: WideString);
begin
  if Assigned(FOnMessage) then
    FOnMessage(Sender, Message);
end;

procedure TConnection.ClientsOnline(Clients: OleVariant);
begin
  if Assigned(FOnClientListChange) then
    FOnClientListChange(Clients);
end;

end.

-----------------------------------------------------

ClientMain:

unit ClientMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, ConnImpl, MsgServer_TLB, StdCtrls, ExtCtrls;

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    memMsg: TMemo;
    Label1: TLabel;
    edtMessage: TEdit;
    btnConnect: TButton;
    btnDisconnect: TButton;
    cbClients: TComboBox;
    procedure btnConnectClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure edtMessageKeyPress(Sender: TObject; var Key: Char);
    procedure btnDisconnectClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    FClient: IClient;
    FConnection: TConnection;
    procedure RecvMessage(const Sender, Message: string);
    procedure ClientsOnline(Clients: OleVariant);
    procedure Disconnect;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  ComObj, ActiveX, Globals;

{$R *.DFM}

procedure TForm1.RecvMessage(const Sender, Message: string);
begin
  memMsg.Lines.Add(Sender + \'> \' + Message);
end;

procedure TForm1.ClientsOnline(Clients: OleVariant);
begin
  cbClients.Clear;
  cbClients.Items.AddObject(\'all\', Pointer(0));

  VariantToStrings(Clients, cbClients.Items);
end;

procedure TForm1.Disconnect;
begin
  if Assigned(FClient) then
    try
      FClient.SendMessage(FConnection, 0, \'logged off \' + DateTimeToStr(Now));
      FClient.Disconnect(FConnection);
      FClient := nil;
    except
      FClient := nil;
    end;
end;

procedure TForm1.btnConnectClick(Sender: TObject);
var
  User: string;
begin
  if not Assigned(FClient) and InputQuery(\'Login\', \'UserName\', User) then
    try
      (FConnection as IConnection).UserName := User;
      FClient := CoClient.Create;
      FClient.Connect(FConnection as IConnection);
      FClient.SendMessage(FConnection, 0, \'logged on \' + DateTimeToStr(Now));
    except
      on e: Exception do
        ShowMessage(\'Connection failed\' + #13 + e.Message);
    end;

  edtMessage.SetFocus;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Disconnect;
end;

procedure TForm1.edtMessageKeyPress(Sender: TObject; var Key: Char);
var
  ID: Integer;
begin
  if Ord(Key) = 13 then
    if Assigned(FConnection) and (edtMessage.Text <> \'\') then
      try
        ID := Integer(cbClients.Items.Objects[cbClients.ItemIndex]);
        FClient.SendMessage(FConnection, ID, edtMessage.Text);
        edtMessage.Clear;
      except
        //ignorer exceptions
      end
    else
      ShowMessage(\'Not connected\');
end;

procedure TForm1.btnDisconnectClick(Sender: TObject);
begin
  Disconnect;
  edtMessage.SetFocus;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FConnection := TConnection.Create;
  FConnection.OnMessage := RecvMessage;
  FConnection.OnClientListChange := ClientsOnline;
end;

end.