Управление свойством Font через сервер автоматизации

unit Project1_TLB;

{ Данный файл содержит паскалевские декларации, импортированные из
библиотеки типов. Данный файл записывается во время каждого импорта
или обновления (refresh) в редакторе библиотеки типов. Любые изменения
в данном файле будут потеряны в процессе очередного обновления. }

{ Библиотека Project1 }
{ Версия 1.0 }

interface

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

const

  LIBID_Project1: TGUID = '{29C7AC94-0807-11D1-B2BA-0020AFF2F575}';

const

  { GUID'ы класса компоненты }

  Class_MyFontServer: TGUID = '{29C7AC96-0807-11D1-B2BA-0020AFF2F575}';

type

  { Предварительные объявления: Интерфейсы }

  IMyFontServer = interface;
  IMyFontServerDisp = dispinterface;

  { Предварительные объявления: CoClasse'ы }

  MyFontServer = IMyFontServer;

  { Диспинтерфейс для объекта MyFontServer }

  IMyFontServer = interface(IDispatch)
    ['{29C7AC95-0807-11D1-B2BA-0020AFF2F575}']
    function Get_MyFont: IFontDisp; safecall;
    procedure Set_MyFont(const Value: IFontDisp); safecall;
    property MyFont: IFontDisp read Get_MyFont write Set_MyFont;
  end;

  { Объявление диспинтерфейса для дуального интерфейса IMyFontServer }

  IMyFontServerDisp = dispinterface
    ['{29C7AC95-0807-11D1-B2BA-0020AFF2F575}']
    property MyFont: IFontDisp dispid 1;
  end;

  { MyFontServerObject }

  CoMyFontServer = class
    class function Create: IMyFontServer;
    class function CreateRemote(const MachineName: string): IMyFontServer;
  end;

implementation

uses ComObj;

class function CoMyFontServer.Create: IMyFontServer;
begin

  Result := CreateComObject(Class_MyFontServer) as IMyFontServer;
end;

class function CoMyFontServer.CreateRemote(const MachineName: string):

IMyFontServer;
begin

  Result := CreateRemoteComObject(MachineName, Class_MyFontServer) as
    IMyFontServer;
end;

end.

{--------------------------------------------------------------------}

unit Unit1;

interface

uses

  ComObj, Project1_TLB, ActiveX, Graphics;

type

  TMyFontServer = class(TAutoObject, IMyFontServer)
  private
    FFont: TFont;
  public
    procedure Initialize; override;
    destructor Destroy; override;
    function Get_MyFont: IFontDisp; safecall;
    procedure Set_MyFont(const Value: IFontDisp); safecall;
  end;

implementation

uses ComServ, AxCtrls, Unit2;

procedure TMyFontServer.Initialize;
begin

  inherited Initialize;
  FFont := TFont.Create;
end;

destructor TMyFontServer.Destroy;
begin

  FFont.Free;
  inherited Destroy;
end;

function TMyFontServer.Get_MyFont: IFontDisp;
begin

  FFont.Assign(Form2.Label1.Font);
  GetOleFont(FFont, Result);
end;

procedure TMyFontServer.Set_MyFont(const Value: IFontDisp);
begin

  SetOleFont(FFont, Value);
  Form2.Label1.Font.Assign(FFont);
end;

initialization

  TAutoObjectFactory.Create(ComServer, TMyFontServer, Class_MyFontServer,
    ciMultiInstance);
end.

{--------------------------------------------------------------------}

unit Unit2;

interface

uses

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

type

  TForm2 = class(TForm)
    Label1: TLabel;
  end;

var

  Form2: TForm2;

implementation

{$R *.DFM}

end.

{--------------------------------------------------------------------}

unit FontCli1;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, StdVCL, Project1_TLB;

type

  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    FontDialog1: TFontDialog;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  public
    MyFontServer: IMyFontServer;
  end;

var

  Form1: TForm1;

implementation

uses ActiveX, AxCtrls;

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var

  Temp: IFontDisp;
begin

  if (FontDialog1.Execute) then
  begin
    Label1.Font.Assign(FontDialog1.Font);
    GetOleFont(Label1.Font, Temp);
    MyFontServer.Set_MyFont(Temp);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin

  MyFontServer := CoMyFontServer.Create;
end;

end.