home *** CD-ROM | disk | FTP | other *** search
/ Chip 1999 March / Chip_1999-03_cd.bin / zkuste / delphi / INFO / DI9807BL.ZIP / CpDisp / Server / ChatChannel.pas next >
Pascal/Delphi Source File  |  1998-05-08  |  5KB  |  141 lines
  1. { *****************************************************************************
  2.   Implementing COM Component Callbacks in Delphi
  3.   Code written for Delphi Informant publication
  4.  
  5.   Comments, questions, suggestions?
  6.   Binh Ly, Systems Analyst (bly@brickhouse.com)
  7.   Brickhouse Data Systems (http://www.brickhouse.com)
  8.   *****************************************************************************
  9. }
  10. unit ChatChannel;
  11.  
  12. interface
  13.  
  14. uses
  15.   Windows, ComObj, ActiveX, ChatServer_TLB, Classes, AxCtrls;
  16.  
  17. type
  18.   TChatChannel = class (TAutoObject, IChatChannel)
  19.   protected
  20.     { IChatChannel }
  21.     function ConnectUser(const Callback: IChatEvent; var UserId: Integer): WordBool; safecall;
  22.     function DisconnectUser(UserId: Integer): WordBool; safecall;
  23.     procedure BroadcastMessage (const UserName, Message: WideString); safecall;
  24.   protected
  25.     FChatUsers : TConnectionPoints;
  26.     FChatEventSinks : TConnectionPoint;
  27.     FDispChatEventSinks : TConnectionPoint;
  28.     procedure Initialize; override;
  29.     function ObjQueryInterface (const IID: TGUID; out Obj): Integer; override;
  30.   public
  31.     destructor Destroy; override;
  32.   end;
  33.  
  34. const
  35.   MainChatChannel : IChatChannel = NIL;
  36.  
  37. implementation
  38.  
  39. uses
  40.   ComServ
  41.   ;
  42.  
  43. { TChatChannel }
  44.  
  45. function TChatChannel.ConnectUser(const Callback: IChatEvent; var UserId: Integer): WordBool;
  46. var
  47.   cpChatUsers : IConnectionPointContainer;
  48.   cpChatEventSinks : IConnectionPoint;
  49. begin
  50.   { Standard connect code for connection points }
  51.   cpChatUsers := Self as IConnectionPointContainer;
  52.   cpChatUsers.FindConnectionPoint (IChatEvent, cpChatEventSinks);
  53.   cpChatEventSinks.Advise (Callback as IUnknown, UserId);
  54.   //OleCheck ((FChatEventSinks as IConnectionPoint).Advise (Callback as IUnknown, UserId));
  55.   Result := TRUE;
  56. end;
  57.  
  58. function TChatChannel.DisconnectUser(UserId: Integer): WordBool;
  59. var
  60.   cpChatUsers : IConnectionPointContainer;
  61.   cpChatEventSinks : IConnectionPoint;
  62. begin
  63.   { Standard disconnect code for connection points }
  64.   cpChatUsers := Self as IConnectionPointContainer;
  65.   cpChatUsers.FindConnectionPoint (IChatEvent, cpChatEventSinks);
  66.   cpChatEventSinks.UnAdvise (UserId);
  67.   //OleCheck ((FChatEventSinks as IConnectionPoint).UnAdvise (UserId));
  68.   Result := TRUE;
  69. end;
  70.  
  71. procedure TChatChannel.BroadcastMessage (const UserName, Message: WideString);
  72. var
  73.   Enum : IEnumConnections;
  74.   ConnectData : TConnectData;
  75.   Fetched : Longint;
  76.   ifDisp : IDispatch;
  77. begin
  78.   { loops through all client connections and issues the callback message broadcast }
  79.   
  80.   { Handle normal ChatEvent sinks }
  81.   OleCheck ((FChatEventSinks as IConnectionPoint).EnumConnections (Enum));
  82.   while Enum.Next (1, ConnectData, @Fetched) = S_OK do
  83.   begin
  84.     try
  85.       (ConnectData.pUnk as IChatEvent).GotMessage (UserName, Message);
  86.       ConnectData.pUnk := nil;
  87.     except
  88.       { if error happened, this callback client probably disconnected
  89.         prematurely; therefore we just ignore the error and process all
  90.         remaining clients.
  91.       }
  92.     end;  { except }
  93.   end;  { while }
  94.  
  95.   { Handle Dispatch only ChatEvent sinks using direct dispatch Id binding }
  96.   Enum := NIL;
  97.   OleCheck ((FDispChatEventSinks as IConnectionPoint).EnumConnections (Enum));
  98.   while Enum.Next (1, ConnectData, @Fetched) = S_OK do
  99.   begin
  100.     try
  101.       ifDisp := ConnectData.pUnk as IDispatch;
  102.       IDispChatEvent (ifDisp).GotMessage (UserName, Message);
  103.       ConnectData.pUnk := nil;
  104.     except
  105.       { if error happened, this callback client probably disconnected
  106.         prematurely; therefore we just ignore the error and process all
  107.         remaining clients.
  108.       }
  109.     end;  { except }
  110.   end;  { while }
  111. end;
  112.  
  113. procedure TChatChannel.Initialize;
  114. begin
  115.   inherited;
  116.   FChatUsers := TConnectionPoints.Create (Self);
  117.   FChatEventSinks := FChatUsers.CreateConnectionPoint (IChatEvent, ckMulti, NIL);
  118.   FDispChatEventSinks := FChatUsers.CreateConnectionPoint (IDispChatEvent, ckMulti, NIL);
  119. end;
  120.  
  121. function TChatChannel.ObjQueryInterface (const IID: TGUID; out Obj): Integer;
  122. begin
  123.   Result := inherited ObjQueryInterface (IID, Obj);
  124.   if not Succeeded (Result) then
  125.     { delegate QueryInterface to FChatUsers for IConnectionPointContainer }
  126.     if (IsEqualIID (IID, IConnectionPointContainer)) then
  127.       if FChatUsers.GetInterface (IID, Obj) then Result := S_OK;
  128. end;
  129.  
  130. destructor TChatChannel.Destroy;
  131. begin
  132.   FDispChatEventSinks.Free;
  133.   FChatEventSinks.Free;
  134.   FChatUsers.Free;
  135.   inherited;
  136. end;
  137.  
  138. initialization
  139.   TAutoObjectFactory.Create(ComServer, TChatChannel, Class_ChatChannel, ciInternal);
  140. end.
  141.