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 5

Project APPSPLUS

Project Structure


APPSPLUS.DPR

program AppSPlus;

uses
  Forms,
  AppSForm in 'AppSForm.pas' {ServerForm},
  AppSPlus_TLB in 'AppSPlus_TLB.pas',
  AppSRDM in 'AppSRDM.pas' {AppServerPlus: TRemoteDataModule} {AppServerPlus: CoClass};

{$R *.TLB}

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TServerForm, ServerForm);
  Application.Run;
end.

APPSFORM.PAS

unit AppSForm;

interface

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

type
  TServerForm = class(TForm)
    lbLog: TListBox;
  private
    { Private declarations }
  public
    procedure Add (strLog: string);
  end;

var
  ServerForm: TServerForm;

implementation

{$R *.DFM}

{ TServerForm }

procedure TServerForm.Add(strLog: string);
begin
  // add item and move to it
  lbLog.ItemIndex := lbLog.Items.Add (strLog);
end;

end.

APPSPLUS_TLB.PAS

unit AppSPlus_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.84  $
// File generated on 8/4/99 5:16:01 PM 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\AppSPlus\AppSPlus.tlb (1)
// IID\LCID: {E31849A6-4A82-11D3-B9F1-00000100A27B}\0
// Helpfile: 
// DepndLst: 
//   (1) v2.0 stdole, (C:\WINDOWS\SYSTEM\STDOLE2.TLB)
//   (2) v4.0 StdVCL, (C:\WINDOWS\SYSTEM\STDVCL40.DLL)
//   (3) v1.0 Midas, (C:\WINDOWS\SYSTEM\MIDAS.DLL)
// ************************************************************************ //
{$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
  AppSPlusMajorVersion = 1;
  AppSPlusMinorVersion = 0;

  LIBID_AppSPlus: TGUID = '{E31849A6-4A82-11D3-B9F1-00000100A27B}';

  IID_IAppServerPlus: TGUID = '{E31849A7-4A82-11D3-B9F1-00000100A27B}';
  CLASS_AppServerPlus: TGUID = '{E31849A9-4A82-11D3-B9F1-00000100A27B}';
type

// *********************************************************************//
// Forward declaration of types defined in TypeLibrary                    
// *********************************************************************//
  IAppServerPlus = interface;
  IAppServerPlusDisp = dispinterface;

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


// *********************************************************************//
// Interface: IAppServerPlus
// Flags:     (4416) Dual OleAutomation Dispatchable
// GUID:      {E31849A7-4A82-11D3-B9F1-00000100A27B}
// *********************************************************************//
  IAppServerPlus = interface(IAppServer)
    ['{E31849A7-4A82-11D3-B9F1-00000100A27B}']
    procedure Login(const Name: WideString; const Password: WideString); safecall;
  end;

// *********************************************************************//
// DispIntf:  IAppServerPlusDisp
// Flags:     (4416) Dual OleAutomation Dispatchable
// GUID:      {E31849A7-4A82-11D3-B9F1-00000100A27B}
// *********************************************************************//
  IAppServerPlusDisp = dispinterface
    ['{E31849A7-4A82-11D3-B9F1-00000100A27B}']
    procedure Login(const Name: WideString; const Password: WideString); dispid 1;
    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 CoAppServerPlus provides a Create and CreateRemote method to          
// create instances of the default interface IAppServerPlus exposed by              
// the CoClass AppServerPlus. The functions are intended to be used by             
// clients wishing to automate the CoClass objects exposed by the         
// server of this typelibrary.                                            
// *********************************************************************//
  CoAppServerPlus = class
    class function Create: IAppServerPlus;
    class function CreateRemote(const MachineName: string): IAppServerPlus;
  end;


// *********************************************************************//
// OLE Server Proxy class declaration
// Server Object    : TAppServerPlus
// Help String      : AppServerPlus Object
// Default Interface: IAppServerPlus
// Def. Intf. DISP? : No
// Event   Interface: 
// TypeFlags        : (2) CanCreate
// *********************************************************************//
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
  TAppServerPlusProperties= class;
{$ENDIF}
  TAppServerPlus = class(TOleServer)
  private
    FIntf:        IAppServerPlus;
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
    FProps:       TAppServerPlusProperties;
    function      GetServerProperties: TAppServerPlusProperties;
{$ENDIF}
    function      GetDefaultInterface: IAppServerPlus;
  protected
    procedure InitServerData; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure Connect; override;
    procedure ConnectTo(svrIntf: IAppServerPlus);
    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);
    procedure Login(const Name: WideString; const Password: WideString);
    property  DefaultInterface: IAppServerPlus read GetDefaultInterface;
  published
{$IFDEF LIVE_SERVER_AT_DESIGN_TIME}
    property Server: TAppServerPlusProperties read GetServerProperties;
{$ENDIF}
  end;

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


procedure Register;

implementation

uses ComObj;

class function CoAppServerPlus.Create: IAppServerPlus;
begin
  Result := CreateComObject(CLASS_AppServerPlus) as IAppServerPlus;
end;

class function CoAppServerPlus.CreateRemote(const MachineName: string): IAppServerPlus;
begin
  Result := CreateRemoteComObject(MachineName, CLASS_AppServerPlus) as IAppServerPlus;
end;

procedure TAppServerPlus.InitServerData;
const
  CServerData: TServerData = (
    ClassID:   '{E31849A9-4A82-11D3-B9F1-00000100A27B}';
    IntfIID:   '{E31849A7-4A82-11D3-B9F1-00000100A27B}';
    EventIID:  '';
    LicenseKey: nil;
    Version: 500);
begin
  ServerData := @CServerData;
end;

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

procedure TAppServerPlus.ConnectTo(svrIntf: IAppServerPlus);
begin
  Disconnect;
  FIntf := svrIntf;
end;

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

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

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

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

function  TAppServerPlus.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  TAppServerPlus.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  TAppServerPlus.AS_DataRequest(const ProviderName: WideString; Data: OleVariant): OleVariant;
begin
  Result := DefaultInterface.AS_DataRequest(ProviderName, Data);
end;

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

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

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

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

procedure TAppServerPlus.Login(const Name: WideString; const Password: WideString);
begin
  DefaultInterface.Login(Name, Password);
end;

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

function TAppServerPlusProperties.GetDefaultInterface: IAppServerPlus;
begin
  Result := FServer.DefaultInterface;
end;

{$ENDIF}

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

end.

APPSRDM.PAS

unit AppSRDM;

interface

uses
  Windows, Messages, SysUtils, Classes, ComServ, ComObj, VCLCom, DataBkr,
  DBClient, AppSPlus_TLB, StdVcl, Db, Provider, DBTables;

type
  TAppServerPlus = class(TRemoteDataModule, IAppServerPlus)
    TableCustomer: TTable;
    TableCustomerCustNo: TFloatField;
    TableCustomerCompany: TStringField;
    TableCustomerAddr1: TStringField;
    TableCustomerAddr2: TStringField;
    TableCustomerCity: TStringField;
    TableCustomerState: TStringField;
    TableCustomerZip: TStringField;
    TableCustomerCountry: TStringField;
    TableCustomerPhone: TStringField;
    TableCustomerFAX: TStringField;
    TableCustomerTaxRate: TFloatField;
    TableCustomerContact: TStringField;
    TableCustomerLastInvoiceDate: TDateTimeField;
    Query: TQuery;
    TableOrders: TTable;
    ProviderOrders: TProvider;
    DataSourceCust: TDataSource;
    ProviderCustomer: TDataSetProvider;
    ProviderQuery: TDataSetProvider;
    procedure ProviderCustomerUpdateData(Sender: TObject;
      DataSet: TClientDataSet);
    procedure ProviderCustomerBeforeUpdateRecord(Sender: TObject;
      SourceDS: TDataSet; DeltaDS: TClientDataSet; UpdateKind: TUpdateKind;
      var Applied: Boolean);
    procedure ProviderQueryGetDataSetProperties(Sender: TObject;
      DataSet: TDataSet; out Properties: OleVariant);
  private
    { Private declarations }
  protected
    class procedure UpdateRegistry(Register: Boolean; const ClassID, ProgID: string); override;
    procedure Login(const Name, Password: WideString); safecall;
  public
    { Public declarations }
  end;

implementation

uses AppSForm;

{$R *.DFM}

class procedure TAppServerPlus.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;

procedure TAppServerPlus.ProviderCustomerUpdateData(Sender: TObject;
  DataSet: TClientDataSet);
begin
  ServerForm.Add ('ProviderCustomer.OnUpdateData');
end;

procedure TAppServerPlus.ProviderCustomerBeforeUpdateRecord(
  Sender: TObject; SourceDS: TDataSet; DeltaDS: TClientDataSet;
  UpdateKind: TUpdateKind; var Applied: Boolean);
begin
  ServerForm.Add ('ProviderCustomer.UpdateRecord');
end;

procedure TAppServerPlus.Login(const Name, Password: WideString);
begin
  // TODO: add actual login code...
  if Password <> Name then
    raise Exception.Create ('Wrong name/password combination received')
  else
    Query.Active := True;
  ServerForm.Add ('Login:' + Name + '/' + Password);
end;

procedure TAppServerPlus.ProviderQueryGetDataSetProperties(Sender: TObject;
  DataSet: TDataSet; out Properties: OleVariant);
begin
  Properties := VarArrayCreate([0,1], varVariant);
  Properties[0] := VarArrayOf(['Time', Now, True]);
  Properties[1] := VarArrayOf(['Param', Query.Params[0].AsString, False]);
end;

initialization
  TComponentFactory.Create(ComServer, TAppServerPlus,
    Class_AppServerPlus, ciMultiInstance, tmApartment);
end.

APPSFORM.DFM

object ServerForm: TServerForm
  Left = 297
  Top = 237
  Width = 696
  Height = 480
  Caption = 'AppServerPlus'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object lbLog: TListBox
    Left = 0
    Top = 0
    Width = 688
    Height = 453
    Align = alClient
    ItemHeight = 13
    TabOrder = 0
  end
end

APPSRDM.DFM

object AppServerPlus: TAppServerPlus
  OldCreateOrder = False
  Left = 279
  Top = 157
  Height = 480
  Width = 696
  object TableCustomer: TTable
    Active = True
    DatabaseName = 'DBDEMOS'
    TableName = 'customer.db'
    Left = 120
    Top = 40
    object TableCustomerCustNo: TFloatField
      FieldName = 'CustNo'
    end
    object TableCustomerCompany: TStringField
      FieldName = 'Company'
      Size = 30
    end
    object TableCustomerAddr1: TStringField
      FieldName = 'Addr1'
      Size = 30
    end
    object TableCustomerAddr2: TStringField
      FieldName = 'Addr2'
      Size = 30
    end
    object TableCustomerCity: TStringField
      FieldName = 'City'
      Size = 15
    end
    object TableCustomerState: TStringField
      FieldName = 'State'
    end
    object TableCustomerZip: TStringField
      FieldName = 'Zip'
      Size = 10
    end
    object TableCustomerCountry: TStringField
      FieldName = 'Country'
    end
    object TableCustomerPhone: TStringField
      FieldName = 'Phone'
      Size = 15
    end
    object TableCustomerFAX: TStringField
      FieldName = 'FAX'
      Size = 15
    end
    object TableCustomerTaxRate: TFloatField
      FieldName = 'TaxRate'
    end
    object TableCustomerContact: TStringField
      FieldName = 'Contact'
    end
    object TableCustomerLastInvoiceDate: TDateTimeField
      FieldName = 'LastInvoiceDate'
    end
  end
  object Query: TQuery
    DatabaseName = 'DBDEMOS'
    SQL.Strings = (
      'select * from customer'
      '  where Country = :Country')
    Left = 112
    Top = 200
    ParamData = <
      item
        DataType = ftString
        Name = 'Country'
        ParamType = ptUnknown
        Value = ''
      end>
  end
  object TableOrders: TTable
    DatabaseName = 'DBDEMOS'
    IndexName = 'CustNo'
    MasterFields = 'CustNo'
    MasterSource = DataSourceCust
    TableName = 'ORDERS.DB'
    Left = 176
    Top = 96
  end
  object ProviderOrders: TProvider
    DataSet = TableOrders
    Constraints = True
    Left = 120
    Top = 96
  end
  object DataSourceCust: TDataSource
    DataSet = TableCustomer
    Left = 184
    Top = 40
  end
  object ProviderCustomer: TDataSetProvider
    DataSet = TableCustomer
    Constraints = True
    OnUpdateData = ProviderCustomerUpdateData
    BeforeUpdateRecord = ProviderCustomerBeforeUpdateRecord
    Left = 56
    Top = 40
  end
  object ProviderQuery: TDataSetProvider
    DataSet = Query
    Constraints = True
    OnGetDataSetProperties = ProviderQueryGetDataSetProperties
    Left = 48
    Top = 200
  end
end