Marco Cantù 1998, Mastering Delphi 4

Project: DBCROSS.DPR


Project Structure


DBCROSS.DPR

program DbCross;

uses
  Forms,
  DbCrossF in 'DbCrossF.pas' {DbCrossForm},
  HtmlData in 'HtmlData.pas';

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TDbCrossForm, DbCrossForm);
  Application.Run;
end.

DBCROSSF.PAS

unit DbCrossF;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, DBTables, StdCtrls, ComCtrls;

type
  TDbCrossForm = class(TForm)
    TableCustomers: TTable;
    TableOrders: TTable;
    TableItems: TTable;
    BtnGenerate: TButton;
    DataSource1: TDataSource;
    TableCustomersCustNo: TFloatField;
    TableCustomersCompany: TStringField;
    TableCustomersAddr1: TStringField;
    TableCustomersAddr2: TStringField;
    TableCustomersCity: TStringField;
    TableCustomersState: TStringField;
    TableCustomersZip: TStringField;
    TableCustomersCountry: TStringField;
    TableCustomersPhone: TStringField;
    TableCustomersFAX: TStringField;
    TableCustomersTaxRate: TFloatField;
    TableCustomersContact: TStringField;
    TableCustomersLastInvoiceDate: TDateTimeField;
    DataSource2: TDataSource;
    TableOrdersOrderNo: TFloatField;
    TableOrdersCustNo: TFloatField;
    TableOrdersSaleDate: TDateTimeField;
    TableOrdersShipDate: TDateTimeField;
    TableOrdersEmpNo: TIntegerField;
    TableOrdersShipToContact: TStringField;
    TableOrdersShipToAddr1: TStringField;
    TableOrdersShipToAddr2: TStringField;
    TableOrdersShipToCity: TStringField;
    TableOrdersShipToState: TStringField;
    TableOrdersShipToZip: TStringField;
    TableOrdersShipToCountry: TStringField;
    TableOrdersShipToPhone: TStringField;
    TableOrdersShipVIA: TStringField;
    TableOrdersPO: TStringField;
    TableOrdersTerms: TStringField;
    TableOrdersPaymentMethod: TStringField;
    TableOrdersItemsTotal: TCurrencyField;
    TableOrdersTaxRate: TFloatField;
    TableOrdersFreight: TCurrencyField;
    TableOrdersAmountPaid: TCurrencyField;
    TableItemsOrderNo: TFloatField;
    TableItemsItemNo: TFloatField;
    TableItemsPartNo: TFloatField;
    TableItemsQty: TIntegerField;
    TableItemsDiscount: TFloatField;
    EditPath: TEdit;
    Label1: TLabel;
    TableParts: TTable;
    TableItemsPart: TStringField;
    TablePartsPartNo: TFloatField;
    TablePartsVendorNo: TFloatField;
    TablePartsDescription: TStringField;
    TablePartsOnHand: TFloatField;
    TablePartsOnOrder: TFloatField;
    TablePartsCost: TCurrencyField;
    TablePartsListPrice: TCurrencyField;
    ButtonMain: TButton;
    ButtonCross: TButton;
    BtnPath: TButton;
    ProgressBar1: TProgressBar;
    procedure BtnGenerateClick(Sender: TObject);
    procedure ButtonMainClick(Sender: TObject);
    procedure ButtonCrossClick(Sender: TObject);
    procedure BtnPathClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  end;

var
  DbCrossForm: TDbCrossForm;

implementation

{$R *.DFM}

uses
  Shellapi, HtmlData, FileCtrl;

// partial version (with no cross reference)
{procedure TDbCrossForm.BtnGenerateClick(Sender: TObject);
var
  HtmlCust, HtmlOrd, HtmlItem: THtmlData;
begin
  // initialize
  Screen.Cursor := crHourglass;
  ProgressBar1.Max := TableCustomers.RecordCount;

  // create the string lists
  HtmlCust := THtmlData.Create (TableCustomers);
  HtmlOrd := THtmlData.Create (TableOrders);
  HtmlItem := THtmlData.Create (TableItems);

  try
    // the main file (customers)
    HtmlCust.AddHeader ('All the Customers');

    // for each customer
    TableCustomers.First;
    while not TableCustomers.EOF do
    begin
      // add a row to the html customers table,
      // linked with the orders of the customer
      HtmlCust.AddTableRow ('Cust');

      // create an order file for each customer
      HtmlOrd.AddHeader (TableCustomersCompany.AsString +
        ' Orders');

      // for each order of the current customer
      TableOrders.First;
      while not TableOrders.EOF do
      begin
        // add the data of the order file,
        // linked with the items of each order
        HtmlOrd.AddTableRow ('Ord');

        // create an item file for each order
        HtmlItem.AddHeader (
          TableCustomersCompany.AsString + ' Order No. ' +
          TableOrders.FieldByName('OrderNo').AsString);

        // for each item of the current order
        while not TableItems.EOF do
        begin
          // add the data of the current item
          // (with no further links)
          HtmlItem.AddTableRow ('');
          TableItems.Next;
        end;

        // save the html file with the items of the order
        HtmlItem.AddFooter;
        HtmlItem.SaveToFile (EditPath.Text + 'Ord' +
          TableOrders.FieldByName('OrderNo').AsString +
          '.htm');
        TableOrders.Next;
      end;

      // save the html file with the orders of the customer
      HtmlOrd.AddFooter;
      HtmlOrd.SaveToFile (EditPath.Text + 'Cust' +
        TableCustomersCustNo.AsString + '.htm');
      TableCustomers.Next;

      // update the UI
      ProgressBar1.Position := TableCustomers.RecNo;
      Application.ProcessMessages;
    end;

    // save the main file with the list of customers
    HtmlCust.AddFooter;
    HtmlCust.SaveToFile (EditPath.Text + 'main.htm');
  finally
    HtmlCust.Free;
    HtmlOrd.Free;
    HtmlItem.Free;
    Beep;
    Screen.Cursor := crDefault;
  end;
end;}

// complete version (with cross reference)
procedure TDbCrossForm.BtnGenerateClick(Sender: TObject);
var
  HtmlCust, HtmlOrd, HtmlItem, HtmlParts: THtmlData;
  HtmlMem: THtmlStrings;
  ListOfLists: TStringList;
  Index: Integer;
begin
  // initialize
  Screen.Cursor := crHourglass;
  ProgressBar1.Max := TableCustomers.RecordCount;

  // create the string lists
  HtmlCust := THtmlData.Create (TableCustomers);
  HtmlOrd := THtmlData.Create (TableOrders);
  HtmlItem := THtmlData.Create (TableItems);
  HtmlParts := THtmlData.Create (TableParts);
  ListOfLists := TStringList.Create;

  try
    // the main file (customers)
    HtmlCust.AddHeader ('All the Customers');

    // for each customer
    TableCustomers.First;
    while not TableCustomers.EOF do
    begin
      // add a row to the html customers table,
      // linked with the orders of the customer
      HtmlCust.AddTableRow ('Cust');

      // create an order file for each customer
      HtmlOrd.AddHeader (TableCustomersCompany.AsString +
        ' Orders');

      // for each order of the current customer
      TableOrders.First;
      while not TableOrders.EOF do
      begin
        // add the data of the order file,
        // linked with the items of each order
        HtmlOrd.AddTableRow ('Ord');

        // create an item file for each order
        HtmlItem.AddHeader (
          TableCustomersCompany.AsString + ' Order No. ' +
          TableOrders.FieldByName('OrderNo').AsString);

        // for each item of the current order
        while not TableItems.EOF do
        begin
          // add the data of the current item
          // (with no further links)
          HtmlItem.AddTableRow ('');

          // look for the part number in the cross
          // reference files in memory
          Index := ListOfLists.IndexOf (
            TableItemsPartNo.AsString);
          // if not found, create a new entry
          if Index < 0 then
          begin
            // create a new string list for this part
            HtmlMem := THtmlStrings.Create;
             HtmlMem.AddHeader ('Part: ' +
              TableItemsPart.AsString);
            // add it to the main list of parts
            Index := ListOfLists.AddObject (
              TableItemsPartNo.AsString, HtmlMem);
          end;
          // in any case, add a new reference to the
          // (existing or new) string list for this part
          THtmlStrings (ListOfLists.Objects[Index]).
            Add ('<a href="Ord' +
              TableItemsOrderNo.AsString + '.htm">' +
              TableCustomersCompany.AsString +
              ' Order No. ' +
              TableOrders.FieldByName('OrderNo').AsString +
              '</a><p>');
          TableItems.Next;
        end;

        // save the html file with the items of the order
        HtmlItem.AddFooter;
        HtmlItem.SaveToFile (EditPath.Text + 'Ord' +
          TableOrders.FieldByName('OrderNo').AsString +
          '.htm');
        TableOrders.Next;
      end;

      // save the html file with the orders of the customer
      HtmlOrd.AddFooter;
      HtmlOrd.SaveToFile (EditPath.Text + 'Cust' +
        TableCustomersCustNo.AsString + '.htm');
      TableCustomers.Next;

      // update the UI
      ProgressBar1.Position := TableCustomers.RecNo;
      Application.ProcessMessages;
    end;

    // save the main file with the list of customers
    HtmlCust.AddFooter;
    HtmlCust.SaveToFile (EditPath.Text + 'main.htm');

    // save each file of the cross reference
    for Index := 0 to ListOfLists.Count - 1 do
    begin
      HtmlMem := THtmlStrings (ListOfLists.Objects[Index]);
      HtmlMem.AddFooter;
      HtmlMem.SaveToFile (EditPath.Text + 'Itx' +
        ListOfLists [Index] + '.htm');
      HtmlMem.Free;
    end;

    // generate the index of the cross reference
    HtmlParts.AddHeader ('Parts Cross Reference');
    TableParts.First;
    while not TableParts.EOF do
    begin
      // add a row to the html customers table
      HtmlParts.AddTableRow ('Itx');
      TableParts.Next;
    end;
    HtmlParts.AddFooter;
    HtmlParts.SaveToFile (EditPath.Text +
      'Parts.htm');

  finally
    HtmlCust.Free;
    HtmlOrd.Free;
    HtmlItem.Free;
    HtmlParts.Free;
    ListOfLists.Free;
    Beep;
    Screen.Cursor := crDefault;
  end;
end;

procedure TDbCrossForm.ButtonMainClick(Sender: TObject);
begin
  // open the main file with the default browser
  ShellExecute (Handle, 'open',
    pChar (EditPath.Text + 'main.htm'),
    '', '', sw_ShowNormal);
end;

procedure TDbCrossForm.ButtonCrossClick(Sender: TObject);
begin
  // open the main file with the default browser
  ShellExecute (Handle, 'open',
    pChar (EditPath.Text + 'parts.htm'),
    '', '', sw_ShowNormal);
end;

procedure TDbCrossForm.BtnPathClick(Sender: TObject);
var
  SelDir: string;
begin
  SelDir := EditPath.Text;
  if SelectDirectory (SelDir,
      [sdAllowCreate, sdPerformCreate, sdPrompt], 0) then
    EditPath.Text := SelDir + '\';
end;

procedure TDbCrossForm.FormCreate(Sender: TObject);
begin
  EditPath.Text := ExtractFilePath (Application.Exename);
end;

end.

HTMLDATA.PAS

unit HtmlData;

interface

uses
  Classes, DB;

type
  THtmlStrings = class (TStringList)
  public
    procedure AddHeader (Title: string); virtual;
    procedure AddFooter; virtual;
  end;

  THtmlData = class (THtmlStrings)
  public
    constructor Create (DataSet: TDataSet);
    procedure AddHeader (Title: string); override;
    procedure AddFooter; override;
    procedure AddTableRow (LinkStr: string);
  private
    Data: TDataSet;
  end;

implementation

uses
  SysUtils;

////// THtmlStrings //////

procedure THtmlStrings.AddHeader (Title: string);
begin
  Clear;
  Add ('<HTML>');
  Add ('<HEAD>');
  Add ('<TITLE>' + Title + '</TITLE>');
  Add ('</HEAD>');
  Add ('<BODY>');
  Add ('<H1><CENTER>' + Title + '</CENTER></H1>');
end;

procedure THtmlStrings.AddFooter;
begin
  Add ('<HR>');
  Add ('Generated by the program ' +
    ExtractFileName (ParamStr(0)));
  Add ('</BODY>');
  Add ('</HTML>');
end;

////// THtlmData //////

constructor THtmlData.Create (DataSet: TDataSet);
begin
  inherited Create;
  Data := DataSet;
end;

procedure THtmlData.AddHeader (Title: string);
var
  I: Integer;
begin
  inherited AddHeader (Title);

  // start table with borders
  Add('<table border>');
  // new row, with the table headers (tag <th>) for the visible fields
  Add('<tr>');
  for I := 0 to Data.FieldCount - 1 do
    if Data.Fields[I].Visible then
      Add('<th>' + Data.Fields[I].FieldName + '</th>');
  Add('</tr>');
end;

procedure THtmlData.AddFooter;
begin
  // end the table
  Add('</table>');

  inherited AddFooter;
end;

procedure THtmlData.AddTableRow (LinkStr: string);
var
  I: Integer;
begin
  // new row, with table data (tag <td>)
  Add('<tr>');
  if LinkStr <> '' then
    // add a link
    Add('<td><a href="' + LinkStr +
      Data.Fields[0].DisplayText + '.htm">'
      + Data.Fields[0].DisplayText + '</a></td>')
  else
    // plain data
    Add('<td>' + Data.Fields[0].DisplayText + '</td>');

  // all the other visible fields
  for I := 1 to Data.FieldCount - 1 do
    if Data.Fields[I].Visible then
      if Data.Fields[I].DisplayText <> '' then
        Add('<td>' + Data.Fields[I].DisplayText + '</td>')
      else
        Add('<td><br></td>');
  Add('</tr>');
end;

end.

DBCROSSF.DFM

object DbCrossForm: TDbCrossForm
  Left = 285
  Top = 110
  Width = 288
  Height = 233
  Caption = 'Database Cross-Reference'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = True
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Label1: TLabel
    Left = 48
    Top = 21
    Width = 94
    Height = 13
    Caption = 'Path for HTML files:'
  end
  object BtnGenerate: TButton
    Left = 48
    Top = 80
    Width = 145
    Height = 25
    Caption = 'Generate &Files'
    TabOrder = 0
    OnClick = BtnGenerateClick
  end
  object EditPath: TEdit
    Left = 48
    Top = 40
    Width = 145
    Height = 21
    ReadOnly = True
    TabOrder = 1
    Text = 'c:\tmp\'
  end
  object ButtonMain: TButton
    Left = 48
    Top = 112
    Width = 145
    Height = 25
    Caption = 'Open &Main'
    TabOrder = 2
    OnClick = ButtonMainClick
  end
  object ButtonCross: TButton
    Left = 48
    Top = 144
    Width = 145
    Height = 25
    Caption = 'Open &Cross Reference'
    TabOrder = 3
    OnClick = ButtonCrossClick
  end
  object BtnPath: TButton
    Left = 200
    Top = 40
    Width = 25
    Height = 21
    Caption = '...'
    TabOrder = 4
    OnClick = BtnPathClick
  end
  object ProgressBar1: TProgressBar
    Left = 8
    Top = 184
    Width = 265
    Height = 16
    Min = 0
    Max = 100
    TabOrder = 5
  end
  object TableCustomers: TTable
    Active = True
    DatabaseName = 'DBDEMOS'
    IndexName = 'ByCompany'
    TableName = 'CUSTOMER.DB'
    Left = 8
    Top = 16
    object TableCustomersCustNo: TFloatField
      FieldName = 'CustNo'
    end
    object TableCustomersCompany: TStringField
      FieldName = 'Company'
      Size = 30
    end
    object TableCustomersAddr1: TStringField
      FieldName = 'Addr1'
      Size = 30
    end
    object TableCustomersAddr2: TStringField
      FieldName = 'Addr2'
      Visible = False
      Size = 30
    end
    object TableCustomersCity: TStringField
      FieldName = 'City'
      Size = 15
    end
    object TableCustomersState: TStringField
      FieldName = 'State'
    end
    object TableCustomersZip: TStringField
      FieldName = 'Zip'
      Size = 10
    end
    object TableCustomersCountry: TStringField
      FieldName = 'Country'
    end
    object TableCustomersPhone: TStringField
      FieldName = 'Phone'
      Size = 15
    end
    object TableCustomersFAX: TStringField
      FieldName = 'FAX'
      Size = 15
    end
    object TableCustomersTaxRate: TFloatField
      FieldName = 'TaxRate'
    end
    object TableCustomersContact: TStringField
      FieldName = 'Contact'
    end
    object TableCustomersLastInvoiceDate: TDateTimeField
      FieldName = 'LastInvoiceDate'
    end
  end
  object TableOrders: TTable
    Active = True
    DatabaseName = 'DBDEMOS'
    IndexName = 'CustNo'
    MasterFields = 'CustNo'
    MasterSource = DataSource1
    TableName = 'ORDERS.DB'
    Left = 8
    Top = 64
    object TableOrdersOrderNo: TFloatField
      FieldName = 'OrderNo'
    end
    object TableOrdersCustNo: TFloatField
      FieldName = 'CustNo'
      Required = True
      Visible = False
    end
    object TableOrdersSaleDate: TDateTimeField
      FieldName = 'SaleDate'
    end
    object TableOrdersShipDate: TDateTimeField
      FieldName = 'ShipDate'
    end
    object TableOrdersEmpNo: TIntegerField
      FieldName = 'EmpNo'
      Required = True
    end
    object TableOrdersShipToContact: TStringField
      FieldName = 'ShipToContact'
    end
    object TableOrdersShipToAddr1: TStringField
      FieldName = 'ShipToAddr1'
      Size = 30
    end
    object TableOrdersShipToAddr2: TStringField
      FieldName = 'ShipToAddr2'
      Size = 30
    end
    object TableOrdersShipToCity: TStringField
      FieldName = 'ShipToCity'
      Size = 15
    end
    object TableOrdersShipToState: TStringField
      FieldName = 'ShipToState'
    end
    object TableOrdersShipToZip: TStringField
      FieldName = 'ShipToZip'
      Size = 10
    end
    object TableOrdersShipToCountry: TStringField
      FieldName = 'ShipToCountry'
    end
    object TableOrdersShipToPhone: TStringField
      FieldName = 'ShipToPhone'
      Size = 15
    end
    object TableOrdersShipVIA: TStringField
      FieldName = 'ShipVIA'
      Size = 7
    end
    object TableOrdersPO: TStringField
      FieldName = 'PO'
      Size = 15
    end
    object TableOrdersTerms: TStringField
      FieldName = 'Terms'
      Size = 6
    end
    object TableOrdersPaymentMethod: TStringField
      FieldName = 'PaymentMethod'
      Size = 7
    end
    object TableOrdersItemsTotal: TCurrencyField
      FieldName = 'ItemsTotal'
    end
    object TableOrdersTaxRate: TFloatField
      FieldName = 'TaxRate'
    end
    object TableOrdersFreight: TCurrencyField
      FieldName = 'Freight'
    end
    object TableOrdersAmountPaid: TCurrencyField
      FieldName = 'AmountPaid'
    end
  end
  object TableItems: TTable
    Active = True
    DatabaseName = 'DBDEMOS'
    IndexName = 'ByOrderNo'
    MasterFields = 'OrderNo'
    MasterSource = DataSource2
    TableName = 'ITEMS.DB'
    Left = 8
    Top = 112
    object TableItemsOrderNo: TFloatField
      FieldName = 'OrderNo'
    end
    object TableItemsItemNo: TFloatField
      FieldName = 'ItemNo'
    end
    object TableItemsPart: TStringField
      FieldKind = fkLookup
      FieldName = 'Part'
      LookupDataSet = TableParts
      LookupKeyFields = 'PartNo'
      LookupResultField = 'Description'
      KeyFields = 'PartNo'
      Size = 30
      Lookup = True
    end
    object TableItemsPartNo: TFloatField
      FieldName = 'PartNo'
    end
    object TableItemsQty: TIntegerField
      FieldName = 'Qty'
    end
    object TableItemsDiscount: TFloatField
      FieldName = 'Discount'
    end
  end
  object DataSource1: TDataSource
    DataSet = TableCustomers
    Left = 208
    Top = 8
  end
  object DataSource2: TDataSource
    DataSet = TableOrders
    Left = 208
    Top = 96
  end
  object TableParts: TTable
    Active = True
    DatabaseName = 'DBDEMOS'
    IndexName = 'ByDescription'
    TableName = 'PARTS.DB'
    Left = 208
    Top = 136
    object TablePartsPartNo: TFloatField
      FieldName = 'PartNo'
    end
    object TablePartsVendorNo: TFloatField
      FieldName = 'VendorNo'
    end
    object TablePartsDescription: TStringField
      FieldName = 'Description'
      Size = 30
    end
    object TablePartsOnHand: TFloatField
      FieldName = 'OnHand'
    end
    object TablePartsOnOrder: TFloatField
      FieldName = 'OnOrder'
    end
    object TablePartsCost: TCurrencyField
      FieldName = 'Cost'
    end
    object TablePartsListPrice: TCurrencyField
      FieldName = 'ListPrice'
    end
  end
end


Copyright Marco Cantù 1998