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 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.126  $
// File generated on 5/13/2001 1:00:17 AM from Type Library described below.

// ************************************************************************  //
// Type Lib: C:\md6code\17\AppSPlus\AppSPlus.tlb (1)
// LIBID: {E31849A6-4A82-11D3-B9F1-00000100A27B}
// LCID: 0
// Helpfile: 
// DepndLst: 
//   (1) v1.0 Midas, (C:\WINDOWS\System32\midas.dll)
//   (2) v2.0 stdole, (C:\WINDOWS\System32\stdole2.tlb)
//   (3) v4.0 StdVCL, (C:\WINDOWS\system32\stdvcl40.dll)
// ************************************************************************ //
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers. 
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}

interface

uses ActiveX, Classes, Graphics, Midas, 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
  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;

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;

end.
AppSRDM.pas
unit AppSRDM;

interface

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

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;
    DataSourceCust: TDataSource;
    ProviderCustomer: TDataSetProvider;
    ProviderQuery: TDataSetProvider;
    procedure ProviderQueryGetDataSetProperties(Sender: TObject;
      DataSet: TDataSet; out Properties: OleVariant);
    procedure ProviderCustomerUpdateData(Sender: TObject;
      DataSet: TCustomClientDataSet);
    procedure ProviderCustomerBeforeUpdateRecord(Sender: TObject;
      SourceDS: TDataSet; DeltaDS: TCustomClientDataSet;
      UpdateKind: TUpdateKind; var Applied: Boolean);
  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.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;

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

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

initialization
  TComponentFactory.Create(ComServer, TAppServerPlus,
    Class_AppServerPlus, ciMultiInstance, tmApartment);
end.
AppSForm.dfm
object ServerForm: TServerForm
  Left = 267
  Top = 215
  Width = 416
  Height = 276
  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 = 408
    Height = 249
    Align = alClient
    ItemHeight = 13
    TabOrder = 0
  end
end
AppSRDM.dfm
object AppServerPlus: TAppServerPlus
  OldCreateOrder = False
  Left = 281
  Top = 200
  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 = 184
    Top = 112
  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