IVCLComObject example

project1.dpr

program project1;

{$APPTYPE CONSOLE}

{$R *.res}

uses
  System.SysUtils,
  Unit1 in 'Unit1.pas' {DataModule1: TDataModule},
  Unit2 in 'Unit2.pas';

procedure Main;
var
  MyInterface: IMyInterface;
begin
  MyInterface := CreateMyInterface;
  MyInterface.Hello;
end;

begin
  ReportMemoryLeaksOnShutdown := True;
  try
    Main;
  except
    on E: Exception do
    begin
      ExitCode := 1;
      Writeln(Format('[%s] %s', [E.ClassName, E.Message]));
    end;
  end;
end.

Unit1.pas

unit Unit1;

interface

uses
  System.SysUtils, System.Classes;

type
  TDataModule1 = class(TDataModule)
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
  private
  public
  end;

implementation

{%CLASSGROUP 'System.Classes.TPersistent'}

{$R *.dfm}

procedure TDataModule1.DataModuleCreate(Sender: TObject);
begin
  Writeln('TDataModule1.OnCreate');
end;

procedure TDataModule1.DataModuleDestroy(Sender: TObject);
begin
  Writeln('TDataModule1.OnDestroy');
end;

end.

Unit2.pas

unit Unit2;

interface

uses
  Classes;

type
  IMyInterface = interface
    ['{6D65DA0C-42FD-4F07-BDFD-741D7689C34A}']
    procedure Hello;
  end;

function CreateMyInterface: IMyInterface;

implementation

uses
  Unit1;

type
  TBaseVCLComObject = class(TInterfacedObject, IVCLComObject)
  private
    FComponent: TComponent;

    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
      stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params;
      VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
    procedure FreeOnRelease;
  public
    constructor Create(AComponent: TComponent);
    destructor Destroy; override;
  end;

  TMyInterface = class(TBaseVCLComObject, IVCLComObject, IMyInterface)
  private
    procedure Hello;
  end;

{ TBaseVCLComObject }

function TBaseVCLComObject.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBaseVCLComObject.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBaseVCLComObject.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer;
  DispIDs: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TBaseVCLComObject.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params;
  VarResult, ExcepInfo, ArgErr: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

procedure TBaseVCLComObject.FreeOnRelease;
begin

end;

constructor TBaseVCLComObject.Create(AComponent: TComponent);
begin
  FComponent := AComponent;
  FComponent.VCLComObject := Pointer(IVCLComObject(Self));
end;

destructor TBaseVCLComObject.Destroy;
begin
  FComponent.Free;
  inherited Destroy;
end;

{ TMyInterface }

procedure TMyInterface.Hello;
begin
  Writeln('TMyInterface.Hello');
end;

function CreateMyInterface: IMyInterface;
begin
  Result := TMyInterface.Create(TDataModule1.Create(nil));
end;

end.