Marco Web Center
[an error occurred while processing this directive]

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

 
© Copyright Marco Cantù, 1995-2020, All rights reserved