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 23 - Project ConvertService

Project Structure

ConvertService.dpr
program ConvertService;

{$APPTYPE CONSOLE}

uses
  WebBroker,
  CGIApp,
  ConvertWebMod in 'ConvertWebMod.pas' {WebModule1: TWebModule},
  ConvertIntf in 'ConvertIntf.pas',
  ConvertImpl in 'ConvertImpl.pas',
  EuroConvConst in 'EuroConvConst.pas';

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TWebModule1, WebModule1);
  Application.Run;
end.
ConvertWebMod.pas
unit ConvertWebMod;

interface

uses
  SysUtils, Classes, HTTPApp, WSDLPub, SOAPPasInv, SOAPHTTPPasInv,
  SoapHTTPDisp, WebBrokerSOAP;

type
  TWebModule1 = class(TWebModule)
    HTTPSoapDispatcher1: THTTPSoapDispatcher;
    HTTPSoapPascalInvoker1: THTTPSoapPascalInvoker;
    WSDLHTMLPublish1: TWSDLHTMLPublish;
    procedure WebModule1WebActionItem1Action(Sender: TObject;
      Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  WebModule1: TWebModule1;

implementation

{$R *.DFM}

uses
  InvokeRegistry, ConvertIntf;

procedure TWebModule1.WebModule1WebActionItem1Action(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
begin
  Response.Content :=
    '<h3>GetMethExternalName - ToEuro</h3><p>' +
    InvRegistry.GetMethExternalName(TypeInfo(IConvert), 'ToEuro') +

    '<h3>GetInterfaceExternalName - IConvert</h3><p>' +
    InvRegistry.GetInterfaceExternalName(TypeInfo(IConvert)) +

    '<h3>GetNamespaceByGUID - IConvert</h3><p>' +
    InvRegistry.GetNamespaceByGUID (IConvert);
end;

end.
ConvertIntf.pas
unit ConvertIntf;

interface

type
  IConvert = interface(IInvokable)
  ['{FF1EAA45-0B94-4630-9A18-E768A91A78E2}']
    function ConvertCurrency (Source, Dest: string; Amount: Double): Double; stdcall;
    function ToEuro (Source: string; Amount: Double): Double; stdcall;
    function FromEuro (Dest: string; Amount: Double): Double; stdcall;
    function TypesList: string; stdcall;
end;

implementation

uses
  InvokeRegistry;

initialization
  InvRegistry.RegisterInterface(TypeInfo(IConvert));
end.
ConvertImpl.pas
unit ConvertImpl;

interface

uses
  Classes, SysUtils, InvokeRegistry, ConvertIntf;

type
  TConvert = class (TInvokableClass, IConvert)
  protected
    function ConvertCurrency (Source, Dest: string; Amount: Double): Double; stdcall;
    function ToEuro (Source: string; Amount: Double): Double; stdcall;
    function FromEuro (Dest: string; Amount: Double): Double; stdcall;
    function TypesList: string; stdcall;
      end;

implementation

uses
  ConvUtils, EuroConvConst;

{ TConvert }

function TConvert.ConvertCurrency(Source, Dest: string;
  Amount: Double): Double;
var
  BaseType, DestType: TConvType;
begin
  if DescriptionToConvType (cbEuroCurrency, Source, BaseType) and
      DescriptionToConvType (cbEuroCurrency, Dest, DestType) then
    Result := EuroConvert (Amount, BaseType, DestType, 4)
  else
    raise Exception.Create ('Undefined currency types');
end;

function TConvert.FromEuro(Dest: string; Amount: Double): Double;
var
  DestType: TConvType;
begin
  Result := 0;
  if DescriptionToConvType (cbEuroCurrency, Dest, DestType) then
    Result := EuroConvert (Amount, cuEUR, DestType, 4);
end;

function TConvert.ToEuro(Source: string; Amount: Double): Double;
var
  BaseType: TConvType;
begin
  Result := 0;
  if DescriptionToConvType (cbEuroCurrency, Source, BaseType) then
    Result := EuroConvert (Amount, BaseType, cuEUR, 4);
end;

function TConvert.TypesList: string;
var
  i: Integer;
  ATypes: TConvTypeArray;
begin
  Result := '';
  GetConvTypes(cbEuroCurrency, ATypes);
  for i := Low(aTypes) to High(aTypes) do
    Result := Result + ConvTypeToDescription (aTypes[i]) + ';';
end;

initialization
  InvRegistry.RegisterInvokableClass (TConvert);
end.
EuroConvConst.pas
unit EuroConvConst;

interface

uses
  ConvUtils;

var
  // Euro Currency Conversion Units
  // basic unit of measurement is Euro
  cbEuroCurrency: TConvFamily;

  cuEUR: TConvType;
  cuDEM: TConvType; // Germany
  cuESP: TConvType; // Spain
  cuFRF: TConvType; // France
  cuIEP: TConvType; // Ireland
  cuITL: TConvType; // Italy
  cuBEF: TConvType; // Belgium
  cuNLG: TConvType; // Holland
  cuATS: TConvType; // Austria
  cuPTE: TConvType; // Portugal
  cuFIM: TConvType; // Finland
  cuGRD: TConvType; // Greece
  cuLUF: TConvType; // Luxembourg

type
  TEuroDecimals = 3..6;

function EuroConvert (const AValue: Double; const AFrom, ATo: TConvType;
  const Decimals: TEuroDecimals = 3): Double;

implementation

uses
  Math;

const
  DEMPerEuros = 1.95583;
  ESPPerEuros = 166.386;
  FRFPerEuros = 6.55957;
  IEPPerEuros =  0.787564;
  ITLPerEuros =  1936.27;
  BEFPerEuros =  40.3399;
  NLGPerEuros =  2.20371;
  ATSPerEuros =  13.7603;
  PTEPerEuros =  200.482;
  FIMPerEuros =  5.94573;
  GRDPerEuros = 340.750;
  LUFPerEuros = 40.3399;

function EuroConvert (const AValue: Double; const AFrom, ATo: TConvType;
  const Decimals: TEuroDecimals = 3): Double;
begin
  // check special case: no conversion
  if AFrom = ATo then
    Result := AValue
  else
  begin
    // convert to Euro, than round
    Result := ConvertFrom (AFrom, AValue);
    Result := RoundTo (Result, -Decimals);
    // convert to currency than round again
    Result := ConvertTo (Result, ATo);
    Result := RoundTo (Result, -Decimals);
  end;
end;


initialization
  // Euro Currency's family type
  cbEuroCurrency := RegisterConversionFamily('EuroCurrency');

  cuEUR := RegisterConversionType(cbEuroCurrency, 'EUR', 1);
  cuDEM := RegisterConversionType(cbEuroCurrency, 'DEM', 1 / DEMPerEuros);
  cuESP := RegisterConversionType(cbEuroCurrency, 'ESP', 1 / ESPPerEuros);
  cuFRF := RegisterConversionType(cbEuroCurrency, 'FRF', 1 / FRFPerEuros);
  cuIEP := RegisterConversionType(cbEuroCurrency, 'IEP', 1 / IEPPerEuros);
  cuITL := RegisterConversionType(cbEuroCurrency, 'ITL', 1 / ITLPerEuros);
  cuBEF := RegisterConversionType(cbEuroCurrency, 'BEF', 1 / BEFPerEuros);
  cuNLG := RegisterConversionType(cbEuroCurrency, 'NLG', 1 / NLGPerEuros);
  cuATS := RegisterConversionType(cbEuroCurrency, 'ATS', 1 / ATSPerEuros);
  cuPTE := RegisterConversionType(cbEuroCurrency, 'PTE', 1 / PTEPerEuros);
  cuFIM := RegisterConversionType(cbEuroCurrency, 'FIM', 1 / FIMPerEuros);
  cuGRD := RegisterConversionType(cbEuroCurrency, 'GRD', 1 / GRDPerEuros);
  cuLUF := RegisterConversionType(cbEuroCurrency, 'LUF', 1 / LUFPerEuros);
end.
ConvertWebMod.dfm
object WebModule1: TWebModule1
  OldCreateOrder = False
  Actions = <
    item
      Name = 'WebActionItem1'
      PathInfo = '/test'
      OnAction = WebModule1WebActionItem1Action
    end>
  Left = 316
  Top = 116
  Height = 170
  Width = 499
  object HTTPSoapDispatcher1: THTTPSoapDispatcher
    Dispatcher = HTTPSoapPascalInvoker1
    WebDispatch.MethodType = mtAny
    WebDispatch.PathInfo = 'soap*'
    Left = 64
    Top = 48
  end
  object HTTPSoapPascalInvoker1: THTTPSoapPascalInvoker
    Converter.Options = [soSendMultiRefObj, soTryAllSchema]
    Left = 208
    Top = 48
  end
  object WSDLHTMLPublish1: TWSDLHTMLPublish
    WebDispatch.MethodType = mtAny
    WebDispatch.PathInfo = 'wsdl*'
    AdminEnabled = False
    Left = 352
    Top = 48
  end
end