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 17 - Project AppServ2

Project Structure

AppServ2.dpr
program AppServ2;

uses
  Forms,
  SrvForm in 'SrvForm.pas' {Form1},
  AppServTwo_TLB in 'AppServTwo_TLB.pas',
  RemoteDM in 'RemoteDM.pas' {RdmCount: TDataModule} {RdmCount: CoClass};

{$R *.RES}

{$R *.TLB}

begin
  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;
end.
SrvForm.pas
unit SrvForm;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

end.
AppServTwo_TLB.pas
unit AppServTwo_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.81  $
// File generated on 8/4/99 10:21:04 AM from Type Library described below.

// *************************************************************************//
// 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.                                                          
// ************************************************************************ //
// Type Lib: C:\md5code\Part5\21\AppServ2\AppServ2.tlb (1)
// IID\LCID: {C5DDE901-2214-11D1-98D0-444553540000}\0
// Helpfile: 
// DepndLst: 
//   (1) v1.0 Midas, (C:\WINDOWS\SYSTEM\MIDAS.DLL)
//   (2) v4.0 StdVCL, (C:\WINDOWS\SYSTEM\STDVCL40.DLL)
//   (3) v2.0 stdole, (C:\WINDOWS\SYSTEM\STDOLE2.TLB)
// ************************************************************************ //
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. 
interface

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

// *********************************************************************//
// 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
  AppServTwoMajorVersion = 1;
  AppServTwoMinorVersion = 0;

  LIBID_AppServTwo: TGUID = '{C5DDE901-2214-11D1-98D0-444553540000}';

  IID_IRdmCount: TGUID = '{C5DDE902-2214-11D1-98D0-444553540000}';
  CLASS_RdmCount: TGUID = '{C5DDE903-2214-11D1-98D0-444553540000}';
type

// *********************************************************************//
// Forward declaration of types defined in TypeLibrary                    
// *********************************************************************//
  IRdmCount = interface;
  IRdmCountDisp = dispinterface;

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


// *********************************************************************//
// Interface: IRdmCount
// Flags:     (4432) Hidden Dual OleAutomation Dispatchable
// GUID:      {C5DDE902-2214-11D1-98D0-444553540000}
// *********************************************************************//
  IRdmCount = interface(IAppServer)
    ['{C5DDE902-2214-11D1-98D0-444553540000}']
  end;

// *********************************************************************//
// DispIntf:  IRdmCountDisp
// Flags:     (4432) Hidden Dual OleAutomation Dispatchable
// GUID:      {C5DDE902-2214-11D1-98D0-444553540000}
// *********************************************************************//
  IRdmCountDisp = dispinterface
    ['{C5DDE902-2214-11D1-98D0-444553540000}']
    function  AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant;
                               MaxErrors: Integer; out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant; dispid 20000000;
    function  AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;
                             Options: Integer; const CommandText: WideString;
                             var Params: OleVariant; var OwnerData: OleVariant): OleVariant; dispid 20000001;
    function  AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant; dispid 20000002;
    function  AS_GetProviderNames: OleVariant; dispid 20000003;
    function  AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant; dispid 20000004;
    function  AS_RowRequest(const ProviderName: WideString; Row: OleVariant; RequestType: Integer;
                             var OwnerData: OleVariant): OleVariant; dispid 20000005;
    procedure AS_Execute(const ProviderName: WideString; const CommandText: WideString;
                          var Params: OleVariant; var OwnerData: OleVariant); dispid 20000006;
  end;

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


// *********************************************************************//
// OLE Server Proxy class declaration
// Server Object    : TRdmCount
// Help String      : RdmCountObject
// Default Interface: IRdmCount
// Def. Intf. DISP? : No
// Event   Interface: 
// TypeFlags        : (2) CanCreate
// *********************************************************************//
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
  TRdmCountProperties= class;
{$ENDIF}
  TRdmCount = class(TOleServer)
  private
    FIntf:        IRdmCount;
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
    FProps:       TRdmCountProperties;
    function      GetServerProperties: TRdmCountProperties;
{$ENDIF}
    function      GetDefaultInterface: IRdmCount;
  protected
    procedure InitServerData; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure Connect; override;
    procedure ConnectTo(svrIntf: IRdmCount);
    procedure Disconnect; override;
    function  AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant;
                               MaxErrors: Integer; out ErrorCount: Integer; var OwnerData: OleVariant): OleVariant;
    function  AS_GetRecords(const ProviderName: WideString; Count: Integer; out RecsOut: Integer;
                             Options: Integer; const CommandText: WideString;
                             var Params: OleVariant; var OwnerData: OleVariant): OleVariant;
    function  AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant;
    function  AS_GetProviderNames: OleVariant;
    function  AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant;
    function  AS_RowRequest(const ProviderName: WideString; Row: OleVariant; RequestType: Integer;
                             var OwnerData: OleVariant): OleVariant;
    procedure AS_Execute(const ProviderName: WideString; const CommandText: WideString;
                          var Params: OleVariant; var OwnerData: OleVariant);
    property  DefaultInterface: IRdmCount read GetDefaultInterface;
  published
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
    property Server: TRdmCountProperties read GetServerProperties;
{$ENDIF}
  end;

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


procedure Register;

implementation

uses ComObj;

class function CoRdmCount.Create: IRdmCount;
begin
  Result := CreateComObject(CLASS_RdmCount) as IRdmCount;
end;

class function CoRdmCount.CreateRemote(const MachineName: string): IRdmCount;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_RdmCount) as IRdmCount;
end;

procedure TRdmCount.InitServerData;
const
  CServerData: TServerData = (
    ClassID:   '{C5DDE903-2214-11D1-98D0-444553540000}';
    IntfIID:   '{C5DDE902-2214-11D1-98D0-444553540000}';
    EventIID:  '';
    LicenseKey: nil;
    Version: 500);
begin
  ServerData := @CServerData;
end;

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

procedure TRdmCount.ConnectTo(svrIntf: IRdmCount);
begin
  Disconnect;
  FIntf := svrIntf;
end;

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

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

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

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

function  TRdmCount.AS_ApplyUpdates(const ProviderName: WideString; Delta: OleVariant;
                                     MaxErrors: Integer; out ErrorCount: Integer;
                                     var OwnerData: OleVariant): OleVariant;
begin
  Result := DefaultInterface.AS_ApplyUpdates(ProviderName, Delta, MaxErrors, ErrorCount, OwnerData);
end;

function  TRdmCount.AS_GetRecords(const ProviderName: WideString; Count: Integer;
                                   out RecsOut: Integer; Options: Integer;
                                   const CommandText: WideString; var Params: OleVariant;
                                   var OwnerData: OleVariant): OleVariant;
begin
  Result := DefaultInterface.AS_GetRecords(ProviderName, Count, RecsOut, Options, CommandText,
                                            Params, OwnerData);
end;

function  TRdmCount.AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant;
begin
  Result := DefaultInterface.AS_DataRequest(ProviderName, Data);
end;

function  TRdmCount.AS_GetProviderNames: OleVariant;
begin
  Result := DefaultInterface.AS_GetProviderNames;
end;

function  TRdmCount.AS_GetParams(const ProviderName: WideString; var OwnerData: OleVariant): OleVariant;
begin
  Result := DefaultInterface.AS_GetParams(ProviderName, OwnerData);
end;

function  TRdmCount.AS_RowRequest(const ProviderName: WideString; Row: OleVariant;
                                   RequestType: Integer; var OwnerData: OleVariant): OleVariant;
begin
  Result := DefaultInterface.AS_RowRequest(ProviderName, Row, RequestType, OwnerData);
end;

procedure TRdmCount.AS_Execute(const ProviderName: WideString; const CommandText: WideString;
                                var Params: OleVariant; var OwnerData: OleVariant);
begin
  DefaultInterface.AS_Execute(ProviderName, CommandText, Params, OwnerData);
end;

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

function TRdmCountProperties.GetDefaultInterface: IRdmCount;
begin
  Result := FServer.DefaultInterface;
end;

{$ENDIF}

procedure Register;
begin
  RegisterComponents('Servers',[TRdmCount]);
end;

end.
RemoteDM.pas
unit RemoteDM;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComServ, ComObj, VCLCom, StdVcl, DataBkr, AppServTwo_TLB, Db,
  DBTables, Provider, DBXpress, FMTBcd, SqlExpr;

type
  TRdmCount = class(TRemoteDataModule, IRdmCount)
    DataSetProvider1: TDataSetProvider;
    SQLConnection1: TSQLConnection;
    SQLDataSet1: TSQLDataSet;
    SQLDataSet1DEPT_NO: TStringField;
    SQLDataSet1EMP_NO: TSmallintField;
    SQLDataSet1FIRST_NAME: TStringField;
    SQLDataSet1HIRE_DATE: TSQLTimeStampField;
    SQLDataSet1JOB_CODE: TStringField;
    SQLDataSet1JOB_COUNTRY: TStringField;
    SQLDataSet1JOB_GRADE: TSmallintField;
    SQLDataSet1LAST_NAME: TStringField;
    SQLDataSet1PHONE_EXT: TStringField;
    SQLDataSet1SALARY: TFMTBCDField;
  protected
    class procedure UpdateRegistry(Register: Boolean; const ClassID,
      ProgID: string); override;
  public
    { Public declarations }
  end;

var
  RdmCount: TRdmCount;

implementation

{$R *.DFM}

class procedure TRdmCount.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
begin
  if Register then
  begin
    inherited UpdateRegistry(Register, ClassID, ProgID);
    EnableSocketTransport(ClassID);
    EnableWebTransport(ClassID);
  end else
  begin
    DisableSocketTransport(ClassID);
    DisableWebTransport(ClassID);
    inherited UpdateRegistry(Register, ClassID, ProgID);
  end;
end;

initialization
  TComponentFactory.Create(ComServer, TRdmCount,
    Class_RdmCount, ciMultiInstance);
end.
SrvForm.dfm
object Form1: TForm1
  Left = 294
  Top = 304
  Width = 313
  Height = 91
  Caption = 'AppServ2'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  Visible = True
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 23
    Top = 16
    Width = 264
    Height = 24
    Caption = 'Remote Data Module Server (2)'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -19
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
end
RemoteDM.dfm
object RdmCount: TRdmCount
  OldCreateOrder = True
  Left = 246
  Top = 110
  Height = 251
  Width = 330
  object DataSetProvider1: TDataSetProvider
    DataSet = SQLDataSet1
    Constraints = True
    Options = [poIncFieldProps]
    Left = 192
    Top = 40
  end
  object SQLConnection1: TSQLConnection
    ConnectionName = 'IBLocal'
    DriverName = 'Interbase'
    GetDriverFunc = 'getSQLDriverINTERBASE'
    LibraryName = 'dbexpint.dll'
    LoginPrompt = False
    Params.Strings = (
      'BlobSize=-1'
      'CommitRetain=False'

              'Database=c:\program files\interbase corp\interbase6\examples\dat' +
        'abase\employee.gdb'
      'DriverName=Interbase'
      'LocaleCode=0x0000'
      'Password=masterkey'
      'RoleName=RoleName'
      'ServerCharSet=ASCII'
      'SQLDialect=1'
      'Interbase TransIsolation=ReadCommited'
      'User_Name=sysdba'
      'WaitOnLocks=True')
    VendorLib = 'GDS32.DLL'
    Left = 64
    Top = 40
  end
  object SQLDataSet1: TSQLDataSet
    SQLConnection = SQLConnection1
    CommandText = 'select * from EMPLOYEE'
    Params = <>
    Left = 120
    Top = 104
    object SQLDataSet1DEPT_NO: TStringField
      FieldName = 'DEPT_NO'
      Required = True
      FixedChar = True
      Size = 3
    end
    object SQLDataSet1EMP_NO: TSmallintField
      CustomConstraint = 'x > 0 and x < 10000'
      ConstraintErrorMessage = 'Employee number must be a positive integer below 10000'
      FieldName = 'EMP_NO'
      Required = True
    end
    object SQLDataSet1FIRST_NAME: TStringField
      CustomConstraint = 'x <> '''''
        ConstraintErrorMessage = 'The first name is required'
      FieldName = 'FIRST_NAME'
      Required = True
      Size = 15
    end
    object SQLDataSet1HIRE_DATE: TSQLTimeStampField
      FieldName = 'HIRE_DATE'
      Required = True
    end
    object SQLDataSet1JOB_CODE: TStringField
      FieldName = 'JOB_CODE'
      Required = True
      Size = 5
    end
    object SQLDataSet1JOB_COUNTRY: TStringField
      FieldName = 'JOB_COUNTRY'
      Required = True
      Size = 15
    end
    object SQLDataSet1JOB_GRADE: TSmallintField
      FieldName = 'JOB_GRADE'
      Required = True
    end
    object SQLDataSet1LAST_NAME: TStringField
      CustomConstraint = 'not x is null'
      ConstraintErrorMessage = 'The last name is required'
      FieldName = 'LAST_NAME'
      Required = True
    end
    object SQLDataSet1PHONE_EXT: TStringField
      FieldName = 'PHONE_EXT'
      Size = 4
    end
    object SQLDataSet1SALARY: TFMTBCDField
      FieldName = 'SALARY'
      Required = True
      Precision = 15
      Size = 2
    end
  end
end