Home: Code Repository: Mastering Delphi 5

Project HTMLPROD

Project Structure

HTMLPROD.DPR
DBHFORM.PAS
DBHFORM.DFM

program HtmlProd;

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

{$R *.RES}

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

unit DBHForm;

interface

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

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;
    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);
  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;

end.

object FormProd: TFormProd
  Left = 190
  Top = 108
  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
  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>'
      ''
      'This is a demo of the page produced by the <b><#appname></b>'
      'application on <b><#date></b>.<p>'
      '<hr>'
      '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>'
      'Capital: <#capital><p>'
      'Continent: <#continent><p>'
      'Area: <#area><p>'
      'Population: <#population><p>'
      '<HR>'
      'Last updated on <#date><br>'
      'HTML file produced by the program <#program>'
      '</BODY></HTML>')
    OnHTMLTag = DataSetPageProducer1HTMLTag
    DataSet = Table1
    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 EmplProd</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 EmplProd</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
end