Sinking events in Delphi (Win32)

[qjd101]

Hi,

If I have an object of type TMyType, which publishes an event StateChanged, how do I hook up to that event?

unit InteropSample;

interface

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

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

var
  Form1: TForm1;

implementation

uses vlibwin32_TLB;

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
  mockDashboard: TMyType;
  text: WideString;
begin
  mockDashboard := TMyType.Create();
  // how do i connect to mockDashboard's StateChange event?
end;

end.

Now the rub comes from the fact that TMyType is a class from .NET, exposed through COM interop. But that's another question - first I need to know how to register with TMyType's event(s). If it's useful to know this - the event is defined as a method in a COM interface IApplicationPublisher, which derives from IUnknown.

Thanks in advance for any help!

 

[whosrdaddy]

is the the vlibwin32_TLB file generated by delphi?

-----------------------------------------------------
What You See Is What You Get
Never underestimate tha powah of tha google!

 

[qjd101]

Yep. After building the .NET class library, I export the ComVisible types using the type library exporter. That produces a dll and a tlb. I use Delphi 2005 to import the type library. Here's the code.

C# code...

using System;
using System.Runtime.InteropServices;
using System.Threading;
using System.Windows.Forms;

[
   Guid("8C050461-C384-493b-AEDC-F546AE1AB924"),
   InterfaceType(ComInterfaceType.InterfaceIsIUnknown)
]
public interface IApplicationPublisher
{
   /// <summary>
   /// The container state changed event.
   /// </summary>
   /// <param name="sender">Sender.</param>
   void ContainerStateChanged(object sender, int id);//[MarshalAs(UnmanagedType.LPStr)] string message);

   /// <summary>
   /// The item state changed event.
   /// </summary>
   /// <param name="sender">Sender.</param>
   void ItemStateChanged(object sender, int id); //[MarshalAs(UnmanagedType.LPStr)] string message);
}

public delegate void NotifyHandler(object sender, int id);

[
   Guid("2E5136A2-8CF6-4769-B40C-B16F4FA0AC1F"),
   ClassInterface(ClassInterfaceType.None),
   ComSourceInterfaces(typeof(IApplicationPublisher))
]
public class Application : IApplicationContainer
{

   #region Member data

   //private IDispatchManager dispatcher;
   private IViewContainer     form = null;  
   
   #endregion

	public Application()
	{
		//dispatcher = new EventDispatcher(ContainerStateChanged, ItemStateChanged);
      Thread.CurrentThread.Name = "APP_THREAD";
	}

   /// <summary>
   /// Fires the ContainerStateChanged event.
   /// </summary>
   public event NotifyHandler ContainerStateChanged;
   
   /// <summary>
   /// Fires the ContainerStateChanged event.
   /// </summary>
   //public event NotifyHandler ItemStateChanged;
   
   #region Member methods

   public void Run()
   {
      form = Loader.CreateContainer();
      form.StateChanging += new NotifyHandler(OnStateChanging);
      (form as TMyType).Show();
   }

   [STAThread]
   private void OnStateChanging(object sender, int id)
   {
      if (ContainerStateChanged != null) { ContainerStateChanged(null, 123); }  
//dispatcher.RaiseContainerEvent(sender, message);
//         Delegate[] subscribers = ContainerStateChanged.GetInvocationList();
//         foreach (Delegate subscriber in subscribers)
//         {
//            (subscriber as NotifyHandler).BeginInvoke(sender, message, new AsyncCallback(this.__dummyOnStateChanging), null);  
//         }
   }

    #endregion
}

public interface IViewContainer 
{
   event NotifyHandler StateChanging; 
   ILayoutManager LayoutManager { get; set; }
}

[ComVisible(false)]
public class TForm : IViewContainer
{
   #region IViewContainer Members

   public ILayoutManager LayoutManager
   {
      get
      {
         // TODO:  Add TForm.LayoutManager getter implementation
         return null;
      }
      set
      {
         // TODO:  Add TForm.LayoutManager setter implementation
      }
   }

   public event SageBI.IntegrationServices.NotifyHandler StateChanging;

   public void Show()
   {
      //test the event firing mechanism through interop 
      if (StateChanging != null) 
      { 
          StateChanging(this, 123); 
      }
   }

   #endregion
}

Now, here is the unit the gets imported. This obviously won't work without registering the dll/type library with COM and I can't figure out a way to upload files. maybe the code will be instructive though.

Delphi...

unit mycompanyname_integration_TLB;

// ************************************************************************ //
// WARNING                                                                    
// -------                                                                    
// The types declared in this file were generated from data read from a       
// Type Library. If this type library is explicitly or indirectly (via        
// another type library referring to this type library) re-imported, or the   
// 'Refresh' command of the Type Library Editor activated while editing the   
// Type Library, the contents of this file will be regenerated and all        
// manual modifications will be lost.                                         
// ************************************************************************ //

// PASTLWTR : 1.2
// File generated on 19/10/2005 11:29:28 from Type Library described below.

// ************************************************************************  //
// Type Lib: C:\Protected\Internal\xxxxxx\Projects\Integration platform\Project1\SystemFrameworksProjects\xxxxxx.integration\bin\Debug\mycompanyname.integration.tlb (1)
// LIBID: {3EB41732-5D04-39D9-9998-D9F5A3275A0E}
// LCID: 0
// Helpfile: 
// HelpString: 
// DepndLst: 
//   (1) v2.0 stdole, (C:\WINDOWS\system32\stdole2.tlb)
//   (2) v1.10 mscorlib, (C:\WINDOWS\Microsoft.NET\Framework\v1.1.4322\mscorlib.tlb)
// Errors:
//   Error creating palette bitmap of (TApplication) : Server mscoree.dll contains no icons
//   Error creating palette bitmap of (TTester) : List index out of bounds (3)
// ************************************************************************ //
// *************************************************************************//
// NOTE:                                                                      
// Items guarded by $IFDEF_LIVE_SERVER_AT_DESIGN_TIME are used by properties  
// which return objects that may need to be explicitly created via a function 
// call prior to any access via the property. These items have been disabled  
// in order to prevent accidental use from within the object inspector. You   
// may enable them by defining LIVE_SERVER_AT_DESIGN_TIME or by selectively   
// removing them from the $IFDEF blocks. However, such items must still be    
// programmatically created via a method of the appropriate CoClass before    
// they can be used.                                                          
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. 
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}
{$VARPROPSETTER ON}
interface

uses Windows, ActiveX, Classes, Graphics, mscorlib_TLB, OleServer, StdVCL, Variants;
  


// *********************************************************************//
// GUIDS declared in the TypeLibrary. Following prefixes are used:        
//   Type Libraries     : LIBID_xxxx                                      
//   CoClasses          : CLASS_xxxx                                      
//   DISPInterfaces     : DIID_xxxx                                       
//   Non-DISP interfaces: IID_xxxx                                        
// *********************************************************************//
const
  // TypeLibrary Major and minor versions
  mycompanyname_integrationMajorVersion = 1;
  mycompanyname_integrationMinorVersion = 0;

  LIBID_mycompanyname_integration: TGUID = '{3EB41732-5D04-39D9-9998-D9F5A3275A0E}';

  IID_IApplicationContainer: TGUID = '{701C21FC-77E4-4969-AB70-CA8521895F5F}';
  IID_IApplicationPublisher: TGUID = '{8C050461-C384-493B-AEDC-F546AE1AB924}';
  CLASS_Application: TGUID = '{2E5136A2-8CF6-4769-B40C-B16F4FA0AC1F}';
  IID__Tester: TGUID = '{43F3DA7F-A351-3CBE-AA5E-E32D9A842461}';
  CLASS_Tester: TGUID = '{A1C5D50E-2357-34CA-8F96-E1F06411ABF7}';
type

// *********************************************************************//
// Forward declaration of types defined in TypeLibrary                    
// *********************************************************************//
  IApplicationContainer = interface;
  IApplicationPublisher = interface;
  _Tester = interface;
  _TesterDisp = dispinterface;

// *********************************************************************//
// Declaration of CoClasses defined in Type Library                       
// (NOTE: Here we map each CoClass to its Default Interface)              
// *********************************************************************//
  Application = IApplicationContainer;
  Tester = _Tester;


// *********************************************************************//
// Interface: IApplicationContainer
// Flags:     (256) OleAutomation
// GUID:      {701C21FC-77E4-4969-AB70-CA8521895F5F}
// *********************************************************************//
  IApplicationContainer = interface(IUnknown)
    ['{701C21FC-77E4-4969-AB70-CA8521895F5F}']
    function Run: HResult; stdcall;
  end;

// *********************************************************************//
// Interface: IApplicationPublisher
// Flags:     (256) OleAutomation
// GUID:      {8C050461-C384-493B-AEDC-F546AE1AB924}
// *********************************************************************//
  IApplicationPublisher = interface(IUnknown)
    ['{8C050461-C384-493B-AEDC-F546AE1AB924}']
    function ContainerStateChanged(sender: OleVariant; id: Integer): HResult; stdcall;
    function ItemStateChanged(sender: OleVariant; id: Integer): HResult; stdcall;
  end;

// *********************************************************************//
// Interface: _Tester
// Flags:     (4432) Hidden Dual OleAutomation Dispatchable
// GUID:      {43F3DA7F-A351-3CBE-AA5E-E32D9A842461}
// *********************************************************************//
  _Tester = interface(IDispatch)
    ['{43F3DA7F-A351-3CBE-AA5E-E32D9A842461}']
  end;

// *********************************************************************//
// DispIntf:  _TesterDisp
// Flags:     (4432) Hidden Dual OleAutomation Dispatchable
// GUID:      {43F3DA7F-A351-3CBE-AA5E-E32D9A842461}
// *********************************************************************//
  _TesterDisp = dispinterface
    ['{43F3DA7F-A351-3CBE-AA5E-E32D9A842461}']
  end;

// *********************************************************************//
// The Class CoApplication provides a Create and CreateRemote method to          
// create instances of the default interface IApplicationContainer exposed by              
// the CoClass Application. The functions are intended to be used by             
// clients wishing to automate the CoClass objects exposed by the         
// server of this typelibrary.                                            
// *********************************************************************//
  CoApplication = class
    class function Create: IApplicationContainer;
    class function CreateRemote(const MachineName: string): IApplicationContainer;
  end;

  TApplicationContainerStateChanged = procedure(ASender: TObject; sender: OleVariant; id: Integer) of object;
  TApplicationItemStateChanged = procedure(ASender: TObject; sender: OleVariant; id: Integer) of object;


// *********************************************************************//
// OLE Server Proxy class declaration
// Server Object    : TApplication
// Help String      : 
// Default Interface: IApplicationContainer
// Def. Intf. DISP? : No
// Event   Interface: IApplicationPublisher
// TypeFlags        : (2) CanCreate
// *********************************************************************//
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
  TApplicationProperties= class;
{$ENDIF}
  TApplication = class(TOleServer)
  private
    FOnContainerStateChanged: TApplicationContainerStateChanged;
    FOnItemStateChanged: TApplicationItemStateChanged;
    FIntf:        IApplicationContainer;
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
    FProps:       TApplicationProperties;
    function      GetServerProperties: TApplicationProperties;
{$ENDIF}
    function      GetDefaultInterface: IApplicationContainer;
  protected
    procedure InitServerData; override;
    procedure InvokeEvent(DispID: TDispID; var Params: TVariantArray); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure Connect; override;
    procedure ConnectTo(svrIntf: IApplicationContainer);
    procedure Disconnect; override;
    function Run: HResult;
    property DefaultInterface: IApplicationContainer read GetDefaultInterface;
  published
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
    property Server: TApplicationProperties read GetServerProperties;
{$ENDIF}
    property OnContainerStateChanged: TApplicationContainerStateChanged read FOnContainerStateChanged write FOnContainerStateChanged;
    property OnItemStateChanged: TApplicationItemStateChanged read FOnItemStateChanged write FOnItemStateChanged;
  end;

{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
// *********************************************************************//
// OLE Server Properties Proxy Class
// Server Object    : TApplication
// (This object is used by the IDE's Property Inspector to allow editing
//  of the properties of this server)
// *********************************************************************//
 TApplicationProperties = class(TPersistent)
  private
    FServer:    TApplication;
    function    GetDefaultInterface: IApplicationContainer;
    constructor Create(AServer: TApplication);
  protected
  public
    property DefaultInterface: IApplicationContainer read GetDefaultInterface;
  published
  end;
{$ENDIF}


// *********************************************************************//
// The Class CoTester provides a Create and CreateRemote method to          
// create instances of the default interface _Tester exposed by              
// the CoClass Tester. The functions are intended to be used by             
// clients wishing to automate the CoClass objects exposed by the         
// server of this typelibrary.                                            
// *********************************************************************//
  CoTester = class
    class function Create: _Tester;
    class function CreateRemote(const MachineName: string): _Tester;
  end;


// *********************************************************************//
// OLE Server Proxy class declaration
// Server Object    : TTester
// Help String      : 
// Default Interface: _Tester
// Def. Intf. DISP? : No
// Event   Interface: 
// TypeFlags        : (2) CanCreate
// *********************************************************************//
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
  TTesterProperties= class;
{$ENDIF}
  TTester = class(TOleServer)
  private
    FIntf:        _Tester;
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
    FProps:       TTesterProperties;
    function      GetServerProperties: TTesterProperties;
{$ENDIF}
    function      GetDefaultInterface: _Tester;
  protected
    procedure InitServerData; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure Connect; override;
    procedure ConnectTo(svrIntf: _Tester);
    procedure Disconnect; override;
    property DefaultInterface: _Tester read GetDefaultInterface;
  published
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
    property Server: TTesterProperties read GetServerProperties;
{$ENDIF}
  end;

{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
// *********************************************************************//
// OLE Server Properties Proxy Class
// Server Object    : TTester
// (This object is used by the IDE's Property Inspector to allow editing
//  of the properties of this server)
// *********************************************************************//
 TTesterProperties = class(TPersistent)
  private
    FServer:    TTester;
    function    GetDefaultInterface: _Tester;
    constructor Create(AServer: TTester);
  protected
  public
    property DefaultInterface: _Tester read GetDefaultInterface;
  published
  end;
{$ENDIF}


procedure Register;

resourcestring
  dtlServerPage = '(none)';

  dtlOcxPage = '(none)';

implementation

uses ComObj;

class function CoApplication.Create: IApplicationContainer;
begin
  Result := CreateComObject(CLASS_Application) as IApplicationContainer;
end;

class function CoApplication.CreateRemote(const MachineName: string): IApplicationContainer;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_Application) as IApplicationContainer;
end;

procedure TApplication.InitServerData;
const
  CServerData: TServerData = (
    ClassID:   '{2E5136A2-8CF6-4769-B40C-B16F4FA0AC1F}';
    IntfIID:   '{701C21FC-77E4-4969-AB70-CA8521895F5F}';
    EventIID:  '{8C050461-C384-493B-AEDC-F546AE1AB924}';
    LicenseKey: nil;
    Version: 500);
begin
  ServerData := @CServerData;
end;

procedure TApplication.Connect;
var
  punk: IUnknown;
begin
  if FIntf = nil then
  begin
    punk := GetServer;
    ConnectEvents(punk);
    Fintf:= punk as IApplicationContainer;
  end;
end;

procedure TApplication.ConnectTo(svrIntf: IApplicationContainer);
begin
  Disconnect;
  FIntf := svrIntf;
  ConnectEvents(FIntf);
end;

procedure TApplication.DisConnect;
begin
  if Fintf <> nil then
  begin
    DisconnectEvents(FIntf);
    FIntf := nil;
  end;
end;

function TApplication.GetDefaultInterface: IApplicationContainer;
begin
  if FIntf = nil then
    Connect;
  Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation');
  Result := FIntf;
end;

constructor TApplication.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
  FProps := TApplicationProperties.Create(Self);
{$ENDIF}
end;

destructor TApplication.Destroy;
begin
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
  FProps.Free;
{$ENDIF}
  inherited Destroy;
end;

{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
function TApplication.GetServerProperties: TApplicationProperties;
begin
  Result := FProps;
end;
{$ENDIF}

procedure TApplication.InvokeEvent(DispID: TDispID; var Params: TVariantArray);
begin
  case DispID of
    -1: Exit;  // DISPID_UNKNOWN
(*{The DispID for this method is DISPID_UNKNOWN!?. }
    -1: if Assigned(FOnContainerStateChanged) then
         FOnContainerStateChanged(Self,
                                  Params[0] {OleVariant},
                                  Params[1] {Integer});
*)
(*{The DispID for this method is DISPID_UNKNOWN!?. }
    -1: if Assigned(FOnItemStateChanged) then
         FOnItemStateChanged(Self,
                             Params[0] {OleVariant},
                             Params[1] {Integer});
*)
  end; {case DispID}
end;

function TApplication.Run: HResult;
begin
  Result := DefaultInterface.Run;
end;

{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
constructor TApplicationProperties.Create(AServer: TApplication);
begin
  inherited Create;
  FServer := AServer;
end;

function TApplicationProperties.GetDefaultInterface: IApplicationContainer;
begin
  Result := FServer.DefaultInterface;
end;

{$ENDIF}

class function CoTester.Create: _Tester;
begin
  Result := CreateComObject(CLASS_Tester) as _Tester;
end;

class function CoTester.CreateRemote(const MachineName: string): _Tester;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_Tester) as _Tester;
end;

procedure TTester.InitServerData;
const
  CServerData: TServerData = (
    ClassID:   '{A1C5D50E-2357-34CA-8F96-E1F06411ABF7}';
    IntfIID:   '{43F3DA7F-A351-3CBE-AA5E-E32D9A842461}';
    EventIID:  '';
    LicenseKey: nil;
    Version: 500);
begin
  ServerData := @CServerData;
end;

procedure TTester.Connect;
var
  punk: IUnknown;
begin
  if FIntf = nil then
  begin
    punk := GetServer;
    Fintf:= punk as _Tester;
  end;
end;

procedure TTester.ConnectTo(svrIntf: _Tester);
begin
  Disconnect;
  FIntf := svrIntf;
end;

procedure TTester.DisConnect;
begin
  if Fintf <> nil then
  begin
    FIntf := nil;
  end;
end;

function TTester.GetDefaultInterface: _Tester;
begin
  if FIntf = nil then
    Connect;
  Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation');
  Result := FIntf;
end;

constructor TTester.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
  FProps := TTesterProperties.Create(Self);
{$ENDIF}
end;

destructor TTester.Destroy;
begin
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
  FProps.Free;
{$ENDIF}
  inherited Destroy;
end;

{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
function TTester.GetServerProperties: TTesterProperties;
begin
  Result := FProps;
end;
{$ENDIF}

{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
constructor TTesterProperties.Create(AServer: TTester);
begin
  inherited Create;
  FServer := AServer;
end;

function TTesterProperties.GetDefaultInterface: _Tester;
begin
  Result := FServer.DefaultInterface;
end;

{$ENDIF}

procedure Register;
begin
  RegisterComponents(dtlServerPage, [TApplication, TTester]);
end;

end.

 

[qjd101]

Oh one other thing - I renamed vlibwin32 to mycompanyname_integration_TLB because the proper namespaces and such conatain sensitive information.