Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 6

Chapter 20 - Project Tlibcli

Project Structure

Tlibcli.dpr
program TLibCli;

uses
  Forms,
  TLibCliF in 'TLibCliF.pas' {ClientForm},
  Tlibdemo_TLB in 'Tlibdemo_TLB.pas';

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TClientForm, ClientForm);
  Application.Run;
end.
TLibCliF.pas
unit TLibCliF;

interface

{$WARN SYMBOL_PLATFORM OFF}

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

type
  TClientForm = class(TForm)
    BtnColor1: TButton;
    BtnColor2: TButton;
    BtnIntf: TButton;
    BtnVariant: TButton;
    BtnDispIntf: TButton;
    Bevel1: TBevel;
    ListResult: TListBox;
    BtnColorBis: TButton;
    procedure FormCreate(Sender: TObject);
    procedure BtnColor1Click(Sender: TObject);
    procedure BtnColor2Click(Sender: TObject);
    procedure BtnIntfClick(Sender: TObject);
    procedure BtnVariantClick(Sender: TObject);
    procedure BtnDispIntfClick(Sender: TObject);
    procedure BtnColorBisClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    MyServer, MyServerBis: Variant;
    IMyServer, IMyServerBis: IFirstServer;
    DMyServer: IFirstServerDisp;
  end;

var
  ClientForm: TClientForm;

implementation

{$R *.DFM}

procedure TClientForm.FormCreate(Sender: TObject);
begin
  // creates server objects
  IMyServer := CoFirstServer.Create;
  DMyServer := CoFirstServer.Create as IFirstServerDisp;
  MyServer := CoFirstServer.Create;
end;

procedure TClientForm.BtnColor1Click(Sender: TObject);
begin
  IMyServer.ChangeColor;
end;

procedure TClientForm.BtnColor2Click(Sender: TObject);
begin
  MyServer.ChangeColor;
end;

procedure TClientForm.BtnIntfClick(Sender: TObject);
var
  I, K: Integer;
  Ticks: Cardinal;
begin
  Screen.Cursor := crHourglass;
  try
    Ticks := GetTickCount;
    K := 0;
    for I := 1 to 100 do
      K := K + IMyServer.Value;
    Ticks := GetTickCount - Ticks;
    ListResult.items.Add (Format (
      'Interface: %d - Seconds %.3f', [K, Ticks / 1000]));
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TClientForm.BtnVariantClick(Sender: TObject);
var
  I, K: Integer;
  Ticks: Cardinal;
begin
  Screen.Cursor := crHourglass;
  try
    Ticks := GetTickCount;
    K := 0;
    for I := 1 to 100 do
      K := K + MyServer.Value;
    Ticks := GetTickCount - Ticks;
    ListResult.items.Add (Format (
      'Variant: %d - Seconds %.3f', [K, Ticks / 1000]));
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TClientForm.BtnDispIntfClick(Sender: TObject);
var
  I, K: Integer;
  Ticks: Cardinal;
begin
  Screen.Cursor := crHourglass;
  try
    Ticks := GetTickCount;
    K := 0;
    for I := 1 to 100 do
      K := K + DMyServer.Value;
    Ticks := GetTickCount - Ticks;
    ListResult.items.Add (Format (
      'DispIntf %d - Seconds %.3f', [K, Ticks / 1000]));
  finally
    Screen.Cursor := crDefault;
  end;
end;

procedure TClientForm.BtnColorBisClick(Sender: TObject);
begin
  if varType (MyServerBis) = varEmpty then
    MyServerBis := CoFirstServer.Create;
  MyServerBis.ChangeColor;

  if not Assigned (IMyServerBis) then
    IMyServerBis := CoFirstServer.Create;
  IMyServerBis.ChangeColor;
end;

end.
Tlibdemo_TLB.pas
unit TLibDemo_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 : $Revision:   1.130  $
// File generated on 6/21/2001 7:04:50 PM from Type Library described below.

// ************************************************************************  //
// Type Lib: C:\md6code\20\TLibDemo\Tlibdemo.tlb (1)
// LIBID: {89855B41-8EFE-11D0-98D0-444553540000}
// LCID: 0
// Helpfile: 
// DepndLst: 
//   (1) v1.0 stdole, (C:\WINDOWS\System32\stdole32.tlb)
//   (2) v2.0 StdType, (C:\WINDOWS\System32\OLEPRO32.DLL)
//   (3) v1.0 StdVCL, (C:\Program Files\X-Setup\bin\STDVCL32.DLL)
// ************************************************************************ //
// *************************************************************************//
// 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}

interface

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



  // *********************************************************************//
// 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
  TLibDemoMajorVersion = 1;
  TLibDemoMinorVersion = 0;

  LIBID_TLibDemo: TGUID = '{89855B41-8EFE-11D0-98D0-444553540000}';

  IID_IFirstServer: TGUID = '{89855B42-8EFE-11D0-98D0-444553540000}';
  CLASS_FirstServer: TGUID = '{89855B43-8EFE-11D0-98D0-444553540000}';
type

// *********************************************************************//
// Forward declaration of types defined in TypeLibrary                    
// *********************************************************************//
  IFirstServer = interface;
  IFirstServerDisp = dispinterface;

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


// *********************************************************************//
// Interface: IFirstServer
// Flags:     (4432) Hidden Dual OleAutomation Dispatchable
// GUID:      {89855B42-8EFE-11D0-98D0-444553540000}
// *********************************************************************//
  IFirstServer = interface(IDispatch)
    ['{89855B42-8EFE-11D0-98D0-444553540000}']
    procedure ChangeColor; safecall;
    function  Get_Value: Integer; safecall;
    procedure Set_Value(Value: Integer); safecall;
    property Value: Integer read Get_Value write Set_Value;
  end;

// *********************************************************************//
// DispIntf:  IFirstServerDisp
// Flags:     (4432) Hidden Dual OleAutomation Dispatchable
// GUID:      {89855B42-8EFE-11D0-98D0-444553540000}
// *********************************************************************//
  IFirstServerDisp = dispinterface
    ['{89855B42-8EFE-11D0-98D0-444553540000}']
    procedure ChangeColor; dispid 1;
    property Value: Integer dispid 2;
  end;

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


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

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


procedure Register;

resourcestring
  dtlServerPage = 'ActiveX';

implementation

uses ComObj;

class function CoFirstServer.Create: IFirstServer;
begin
  Result := CreateComObject(CLASS_FirstServer) as IFirstServer;
end;

class function CoFirstServer.CreateRemote(const MachineName: string): IFirstServer;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_FirstServer) as IFirstServer;
end;

procedure TFirstServer.InitServerData;
const
  CServerData: TServerData = (
    ClassID:   '{89855B43-8EFE-11D0-98D0-444553540000}';
    IntfIID:   '{89855B42-8EFE-11D0-98D0-444553540000}';
    EventIID:  '';
    LicenseKey: nil;
    Version: 500);
begin
  ServerData := @CServerData;
end;

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

procedure TFirstServer.ConnectTo(svrIntf: IFirstServer);
begin
  Disconnect;
  FIntf := svrIntf;
end;

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

function TFirstServer.GetDefaultInterface: IFirstServer;
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 TFirstServer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
  FProps := TFirstServerProperties.Create(Self);
{$ENDIF}
end;

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

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

function  TFirstServer.Get_Value: Integer;
begin
  Result := DefaultInterface.Value;
end;

procedure TFirstServer.Set_Value(Value: Integer);
begin
  DefaultInterface.Value := Value;
end;

procedure TFirstServer.ChangeColor;
begin
  DefaultInterface.ChangeColor;
end;

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

function TFirstServerProperties.GetDefaultInterface: IFirstServer;
begin
  Result := FServer.DefaultInterface;
end;

function  TFirstServerProperties.Get_Value: Integer;
begin
  Result := DefaultInterface.Value;
end;

procedure TFirstServerProperties.Set_Value(Value: Integer);
begin
  DefaultInterface.Value := Value;
end;

{$ENDIF}

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

end.
TLibCliF.dfm
object ClientForm: TClientForm
  Left = 204
  Top = 115
  Width = 464
  Height = 295
  Caption = 'Type Library Client'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Bevel1: TBevel
    Left = 16
    Top = 64
    Width = 417
    Height = 193
    HelpType = htKeyword
  end
  object BtnColor1: TButton
    Left = 32
    Top = 16
    Width = 113
    Height = 25
    Caption = 'Change Color 1'
    TabOrder = 0
    OnClick = BtnColor1Click
  end
  object BtnColor2: TButton
    Left = 168
    Top = 16
    Width = 113
    Height = 25
    Caption = 'Change Color 2'
    TabOrder = 1
    OnClick = BtnColor2Click
  end
  object BtnIntf: TButton
    Left = 32
    Top = 96
    Width = 113
    Height = 25
    Caption = 'Compute (Interface)'
    TabOrder = 2
    OnClick = BtnIntfClick
  end
  object BtnVariant: TButton
    Left = 32
    Top = 144
    Width = 113
    Height = 25
    Caption = 'Compute (Variant)'
    TabOrder = 3
    OnClick = BtnVariantClick
  end
  object BtnDispIntf: TButton
    Left = 32
    Top = 192
    Width = 113
    Height = 25
    Caption = 'Compute (DispIntf)'
    TabOrder = 4
    OnClick = BtnDispIntfClick
  end
  object ListResult: TListBox
    Left = 160
    Top = 80
    Width = 257
    Height = 161
    ItemHeight = 13
    TabOrder = 5
  end
  object BtnColorBis: TButton
    Left = 304
    Top = 16
    Width = 113
    Height = 25
    Caption = 'Change Color Bis'
    TabOrder = 6
    OnClick = BtnColorBisClick
  end
end