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 21 - Project HtmlProd

Project Structure

HtmlProd.dpr
program HtmlProd;

uses
  Forms,
  DBHForm in 'DBHForm.pas' {FormProd};

{$R *.RES}

begin
  Application.CreateForm(TFormProd, FormProd);
  Application.Run;
end.
DBHForm.pas
unit DBHForm;

interface

uses
  SysUtils, Windows, Messages, Classes, Graphics,
  Controls, Forms, DBCtrls, StdCtrls, DBTables,
  ExtCtrls, Mask, Db, Dialogs, HTTPApp, DSProd, DBWeb, HTTPProd,
  IdBaseComponent, IdComponent, IdTCPServer, IdHTTPServer;

type
  TFormProd = class(TForm)
    BtnPrintAll: TButton;
    DBEdit3: TDBEdit;
    Label3: TLabel;
    Label2: TLabel;
    DBEdit2: TDBEdit;
    DBEdit1: TDBEdit;
    Label1: TLabel;
    DBNavigator1: TDBNavigator;
    Table1: TTable;
    DataSource1: TDataSource;
    SaveDialog1: TSaveDialog;
    Memo1: TMemo;
    BtnSave: TButton;
    CheckStart: TCheckBox;
    BtnLine: TButton;
    PageProducer1: TPageProducer;
    DataSetPageProducer1: TDataSetPageProducer;
    Table1Name: TStringField;
    Table1Capital: TStringField;
    Table1Continent: TStringField;
    Table1Area: TFloatField;
    Table1Population: TFloatField;
    BtnDemo: TButton;
    DataSetTableProducer1: TDataSetTableProducer;
    DataSetTableProducer2: TDataSetTableProducer;
    cbCss: TCheckBox;
    IdHTTPServer1: TIdHTTPServer;
    procedure BtnPrintAllClick(Sender: TObject);
    procedure BtnSaveClick(Sender: TObject);
    procedure BtnLineClick(Sender: TObject);
    procedure DataSetPageProducer1HTMLTag(Sender: TObject; Tag: TTag;
      const TagString: String; TagParams: TStrings;
      var ReplaceText: String);
    procedure PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
      const TagString: String; TagParams: TStrings;
      var ReplaceText: String);
    procedure BtnDemoClick(Sender: TObject);
    procedure DataSetTableProducer1FormatCell(Sender: TObject; CellRow,
      CellColumn: Integer; var BgColor: THTMLBgColor;
      var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
      CellData: String);
    procedure DataSetTableProducer2FormatCell(Sender: TObject; CellRow,
      CellColumn: Integer; var BgColor: THTMLBgColor;
      var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
      CellData: String);
    procedure IdHTTPServer1CommandGet(AThread: TIdPeerThread;
      RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
  end;

var
  FormProd: TFormProd;

implementation

{$R *.DFM}

uses
  ShellAPI;

procedure TFormProd.BtnPrintAllClick(Sender: TObject);
begin
  Table1.First;
  Memo1.Clear;
  if not cbCss.Checked then
    Memo1.Text := DataSetTableProducer1.Content
  else
    Memo1.Text := DataSetTableProducer2.Content;
  BtnSave.Enabled := True;
end;

procedure TFormProd.BtnSaveClick(Sender: TObject);
begin
  if SaveDialog1.Execute then
  begin
    Memo1.Lines.SaveToFile (SaveDialog1.FileName);
    if CheckStart.Checked then
      ShellExecute (Handle, 'open',
        PChar (SaveDialog1.FileName),
        '', '', sw_ShowNormal);
  end;
end;

procedure TFormProd.BtnLineClick(Sender: TObject);
begin
  Memo1.Clear;
  Memo1.Text := DataSetPageProducer1.Content;
  BtnSave.Enabled := True;
end;

procedure TFormProd.DataSetPageProducer1HTMLTag(Sender: TObject; Tag: TTag;
  const TagString: String; TagParams: TStrings; var ReplaceText: String);
begin
  if TagString = 'program' then
    ReplaceText := ExtractFilename (Forms.Application.Exename)
  else if TagString = 'date' then
    ReplaceText := DateToStr (Date);
end;

procedure TFormProd.PageProducer1HTMLTag(Sender: TObject; Tag: TTag;
  const TagString: String; TagParams: TStrings; var ReplaceText: String);
var
  nDays: Integer;
begin
  if TagString = 'date' then
    ReplaceText := DateToStr (Now)
  else if TagString = 'appname' then
    ReplaceText := ExtractFilename (Forms.Application.Exename)
  else if TagString = 'expiration' then
  begin
    nDays := StrToIntDef (TagParams.Values['days'], 0);
    if nDays <> 0 then
      ReplaceText := DateToStr (Now + nDays)
    else
      ReplaceText := '<I>{expiration tag error}</I>';
  end;
end;

procedure TFormProd.BtnDemoClick(Sender: TObject);
begin
  Memo1.Clear;
  Memo1.Text := PageProducer1.Content;
  BtnSave.Enabled := True;
end;

procedure TFormProd.DataSetTableProducer1FormatCell(Sender: TObject;
  CellRow, CellColumn: Integer; var BgColor: THTMLBgColor;
  var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
  CellData: String);
begin
  if (CellRow > 0) and (((CellColumn = 3) and (Length (CellData) > 8)) or
     ((CellColumn = 4) and (Length (CellData) > 9))) then
  begin
    BgColor := 'red';
    CellData := '<b>' + CellData + '</b>';
  end;
end;

procedure TFormProd.DataSetTableProducer2FormatCell(Sender: TObject;
  CellRow, CellColumn: Integer; var BgColor: THTMLBgColor;
  var Align: THTMLAlign; var VAlign: THTMLVAlign; var CustomAttrs,
  CellData: String);
begin
  if (CellRow > 0) and (((CellColumn = 3) and (Length (CellData) > 8)) or
      ((CellColumn = 4) and (Length (CellData) > 9))) then
    CustomAttrs := 'class="highlight"';
end;

procedure TFormProd.IdHTTPServer1CommandGet(AThread: TIdPeerThread;
  RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
var
  I: Integer;
  Req, Html: String;
  CssTest: TStringList;
  Comp: TComponent;
begin
  // version 1: see what's selected
  // ResponseInfo.ContentText := Memo1.Text;

  // version 2: use path
  Req := RequestInfo.Document;
  if Pos ('test.css', Req) > 0 then
  begin
    CssTest := TStringList.Create;
    try
      CssTest.LoadFromFile (ExtractFilePath (
        Application.ExeName) + 'test.css');
      ResponseInfo.ContentText := CssTest.Text;
      ResponseInfo.ContentType := 'text/css';
    finally
      CssTest.Free;
    end;
    Exit;
  end;
  // standard request
  if Req [1] = '/' then
    Req := Copy (Req, 2, 1000); // skip '/'
  Comp := FindComponent (Req);
  if (Req <> '') and Assigned (Comp) and
    (Comp is TCustomContentProducer) then
  begin
    Table1.First;
    Html := TCustomContentProducer (Comp).Content;
  end
  else
  begin
    // define a menu
    Html := '<h1>Html Proc Menu<h1><p><ul>';
    for I := 0 to ComponentCount - 1 do
      if Components [i] is TCustomContentProducer then
        Html := Html + '<li><a href="/' + Components [i].Name +
          '">' + Components [i].Name + '</a></li>';
    Html := Html + '</ul></p>';
  end;
  ResponseInfo.ContentText := Html;
end;

end.
DBHForm.dfm
object FormProd: TFormProd
  Left = 209
  Top = 111
  Width = 411
  Height = 407
  Caption = 'HtmlProc'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clBlack
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  DesignSize = (
    403
    380)
  PixelsPerInch = 96
  TextHeight = 13
  object Label3: TLabel
    Left = 40
    Top = 124
    Width = 48
    Height = 13
    Caption = 'Continent:'
  end
  object Label2: TLabel
    Left = 40
    Top = 91
    Width = 35
    Height = 13
    Caption = 'Capital:'
  end
  object Label1: TLabel
    Left = 40
    Top = 56
    Width = 39
    Height = 13
    Caption = 'Country:'
  end
  object BtnPrintAll: TButton
    Left = 295
    Top = 108
    Width = 89
    Height = 25
    Anchors = [akTop, akRight]
    Caption = '&Print Table'
    TabOrder = 0
    OnClick = BtnPrintAllClick
  end
  object DBEdit3: TDBEdit
    Left = 104
    Top = 120
    Width = 169
    Height = 21
    DataField = 'Continent'
    DataSource = DataSource1
    TabOrder = 1
  end
  object DBEdit2: TDBEdit
    Left = 104
    Top = 86
    Width = 169
    Height = 21
    DataField = 'Capital'
    DataSource = DataSource1
    TabOrder = 2
  end
  object DBEdit1: TDBEdit
    Left = 104
    Top = 52
    Width = 169
    Height = 21
    DataField = 'Name'
    DataSource = DataSource1
    TabOrder = 3
  end
  object DBNavigator1: TDBNavigator
    Left = 0
    Top = 0
    Width = 403
    Height = 25
    DataSource = DataSource1
    VisibleButtons = [nbFirst, nbPrior, nbNext, nbLast, nbInsert, nbEdit, nbPost, nbCancel]
    Align = alTop
    Flat = True
    TabOrder = 4
  end
  object Memo1: TMemo
    Left = 16
    Top = 184
    Width = 369
    Height = 180
    Anchors = [akLeft, akTop, akRight, akBottom]
    ScrollBars = ssVertical
    TabOrder = 5
  end
  object BtnSave: TButton
    Left = 295
    Top = 146
    Width = 89
    Height = 25
    Anchors = [akTop, akRight]
    Caption = '&Save HTML'
    Enabled = False
    TabOrder = 6
    OnClick = BtnSaveClick
  end
  object CheckStart: TCheckBox
    Left = 192
    Top = 153
    Width = 89
    Height = 17
    Caption = 'Start &Browser'
    Checked = True
    State = cbChecked
    TabOrder = 7
  end
  object BtnLine: TButton
    Left = 295
    Top = 70
    Width = 89
    Height = 25
    Anchors = [akTop, akRight]
    Caption = 'Print &Line'
    TabOrder = 8
    OnClick = BtnLineClick
  end
  object BtnDemo: TButton
    Left = 295
    Top = 32
    Width = 89
    Height = 25
    Anchors = [akTop, akRight]
    Caption = 'Demo &Page'
    TabOrder = 9
    OnClick = BtnDemoClick
  end
  object cbCss: TCheckBox
    Left = 105
    Top = 153
    Width = 57
    Height = 17
    Caption = 'CSS'
    TabOrder = 10
  end
  object Table1: TTable
    Active = True
    DatabaseName = 'DBDEMOS'
    TableName = 'COUNTRY.DB'
    Left = 16
    Top = 48
    object Table1Name: TStringField
      FieldName = 'Name'
      Size = 24
    end
    object Table1Capital: TStringField
      FieldName = 'Capital'
      Size = 24
    end
    object Table1Continent: TStringField
      CustomConstraint = 'X = ''South America'' OR X = ''North America'''
                ConstraintErrorMessage = 'Country is not in the American Continent'
      DefaultExpression = '''South America'''
        FieldName = 'Continent'
      Size = 24
    end
    object Table1Area: TFloatField
      FieldName = 'Area'
      DisplayFormat = '###,###,###'
    end
    object Table1Population: TFloatField
      FieldName = 'Population'
      DisplayFormat = '###,###,###'
    end
  end
  object DataSource1: TDataSource
    DataSet = Table1
    Left = 16
    Top = 96
  end
  object SaveDialog1: TSaveDialog
    DefaultExt = 'HTM'
    Filter = 'HTML file (*.htm)|*.htm|Any file (*.*)|*.*'
    Options = [ofOverwritePrompt, ofPathMustExist, ofCreatePrompt]
    Left = 16
  end
  object PageProducer1: TPageProducer
    HTMLDoc.Strings = (
      '<html>'
      '<head>'
      '<title>Producer Demo</title>'
      '</head>'
      '<body>'
      '<h1>Producer Demo</h1>'
      '<p>This is a demo of the page produced by the'
      '<b><#appname></b> application on <b><#date></b>.</p>'
      '<hr>'
      '<p>The prices in this catalog are valid until'
      '<b><#expiration days=21></b>.</p>'
      '</body>'
      '</html>')
    OnHTMLTag = PageProducer1HTMLTag
    Left = 64
    Top = 192
  end
  object DataSetPageProducer1: TDataSetPageProducer
    HTMLDoc.Strings = (
      '<HTML><HEAD>'
      '<TITLE>Data for <#name></TITLE>'
      '</HEAD><BODY>'
      '<H1><CENTER>Data for <#name></CENTER></H1>'
      '<p>Capital: <#capital></p>'
      '<p>Continent: <#continent></p>'
      '<p>Area: <#area></p>'
      '<p>Population: <#population></p>'
      '<HR>'
      '<p>Last updated on <#date><br>'
      'HTML file produced by the program <#program>.</p>'
      '</BODY></HTML>')
    DataSet = Table1
    OnHTMLTag = DataSetPageProducer1HTMLTag
    Left = 64
    Top = 240
  end
  object DataSetTableProducer1: TDataSetTableProducer
    Caption = '<h2>American Countries</h2>'
    Columns = <
      item
        BgColor = 'Silver'
        FieldName = 'Name'
        Title.Align = haLeft
        Title.BgColor = 'Silver'
        Title.Caption = 'Country'
      end
      item
        FieldName = 'Capital'
      end
      item
        FieldName = 'Continent'
      end
      item
        Align = haRight
        FieldName = 'Area'
      end
      item
        Align = haRight
        FieldName = 'Population'
      end>
    Footer.Strings = (
      '<hr><i>Produced by HtmlProd</i>'
      '</body></html>')
    Header.Strings = (
      '<html><head>'
      '<title>DataSetTableProducer Demo</title>'
      ''
      '</head><body>'
      '<h1><center>DataSetTableProducer Demo</center></h1>')
    MaxRows = -1
    DataSet = Table1
    TableAttributes.Border = 1
    TableAttributes.CellSpacing = 1
    TableAttributes.CellPadding = 5
    OnFormatCell = DataSetTableProducer1FormatCell
    Left = 208
    Top = 192
  end
  object DataSetTableProducer2: TDataSetTableProducer
    Caption = '<h2>American Countries</h2>'
    Columns = <
      item
        BgColor = 'Silver'
        FieldName = 'Name'
        Title.Align = haLeft
        Title.BgColor = 'Silver'
        Title.Caption = 'Country'
      end
      item
        FieldName = 'Capital'
      end
      item
        FieldName = 'Continent'
      end
      item
        Align = haRight
        FieldName = 'Area'
      end
      item
        Align = haRight
        FieldName = 'Population'
      end>
    Footer.Strings = (
      '<hr><i>Produced by HtmlProd</i>'
      '</body></html>')
    Header.Strings = (
      '<html><head>'
      '<link rel="stylesheet" type="text/css" href="test.css">'
      '<title>DataSetTableProducer Demo</title>'
      ''
      '</head><body>'
      '<h1><center>DataSetTableProducer Demo</center></h1>')
    MaxRows = -1
    DataSet = Table1
    TableAttributes.Border = 1
    TableAttributes.CellPadding = 5
    OnFormatCell = DataSetTableProducer2FormatCell
    Left = 208
    Top = 240
  end
  object IdHTTPServer1: TIdHTTPServer
    Active = True
    Bindings = <>
    DefaultPort = 8080
    OnCommandGet = IdHTTPServer1CommandGet
    ParseParams = False
    Left = 64
    Top = 296
  end
end