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