Marco Cantù 1998, Mastering Delphi 4
Project: TABLES.DPR
Project Structure
TABLES.DPR
program Tables;
uses
Forms,
TablesF in 'TablesF.pas' {MainForm},
FieldsF in 'FieldsF.pas' {FieldsForm},
HtmlStr in 'HtmlStr.pas';
{$R *.RES}
begin
Application.CreateForm(TMainForm, MainForm);
Application.CreateForm(TFieldsForm, FieldsForm);
Application.Run;
end.
TABLESF.PAS
unit TablesF;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, DB, ExtCtrls, Buttons, Grids,
DBGrids, DBTables;
type
TMainForm = class(TForm)
ListBox1: TListBox;
Panel1: TPanel;
ComboBox1: TComboBox;
Label1: TLabel;
Table1: TTable;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
SpeedButton1: TSpeedButton;
Splitter1: TSplitter;
SpeedButton2: TSpeedButton;
SaveDialog1: TSaveDialog;
CheckBox1: TCheckBox;
procedure FormCreate(Sender: TObject);
procedure ComboBox1Change(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
procedure SpeedButton2Click(Sender: TObject);
private
{ Private declarations }
end;
var
MainForm: TMainForm;
implementation
{$R *.DFM}
uses
FieldsF, HtmlStr, ShellAPI;
procedure TMainForm.FormCreate(Sender: TObject);
begin
Session.GetDatabaseNames (
ComboBox1.Items);
// force an initial list in the listbox
ComboBox1.ItemIndex := 0;
ComboBox1Change (self);
// force an initial selection in the DBGrid
ListBox1.ItemIndex := 0;
ListBox1Click (self);
end;
procedure TMainForm.ComboBox1Change(Sender: TObject);
begin
Session.GetTableNames (
ComboBox1.Text, '',
True, False, ListBox1.Items);
end;
procedure TMainForm.ListBox1Click(Sender: TObject);
begin
Table1.Close;
Table1.DatabaseName := ComboBox1.Text;
Table1.Tablename :=
Listbox1.Items [Listbox1.ItemIndex];
Table1.Open;
Caption := Format ('Table: %s - %s',
[Table1.DatabaseName,
Table1.Tablename]);
end;
procedure TMainForm.SpeedButton1Click(Sender: TObject);
var
I: Integer;
begin
FieldsForm.FieldsList.Clear;
for I := 0 to Table1.FieldCount - 1 do
begin
FieldsForm.FieldsList.Items.Add (
Table1.Fields[I].FieldName);
FieldsForm.FieldsList.Selected [I] :=
Table1.Fields[I].Visible;
end;
if FieldsForm.ShowModal = mrOk then
for I := 0 to Table1.FieldCount - 1 do
Table1.Fields[I].Visible :=
FieldsForm.FieldsList.Selected [I];
end;
procedure TMainForm.SpeedButton2Click(Sender: TObject);
var
Str: THtmlStrings;
begin
SaveDialog1.FileName := ChangeFileExt (
Table1.TableName, '.htm');
if SaveDialog1.Execute then
begin
Str := THtmlStrings.Create;
try
Str.AddHeader (Caption);
Str.OutputTable (Table1);
Str.AddFooter;
Str.SaveToFile (SaveDialog1.Filename);
if CheckBox1.Checked then
ShellExecute (Handle, 'open',
PChar (SaveDialog1.FileName),
'', '', sw_ShowNormal);
finally
Str.Free;
end;
end;
end;
end.
FIELDSF.PAS
unit FieldsF;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons, ExtCtrls;
type
TFieldsForm = class(TForm)
FieldsList: TListBox;
Panel1: TPanel;
Label1: TLabel;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
private
{ Private declarations }
public
{ Public declarations }
end;
var
FieldsForm: TFieldsForm;
implementation
{$R *.DFM}
end.
HTMLSTR.PAS
unit HtmlStr;
interface
uses
Classes, DB;
type
THtmlStrings = class (TStringList)
public
procedure AddHeader (Title: string);
procedure AddFooter;
procedure OutputTable (Data: TDataSet);
private
procedure AddTableContents (Data: TDataSet);
end;
implementation
uses
SysUtils;
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 (Application.Exename));
Add ('</BODY>');
Add ('</HTML>');
end;
procedure THtmlStrings.OutputTable (Data: TDataSet);
var
I: Integer;
begin
// start table with borders
Add('<table border>');
// new row, with the table headers (tag <th>)
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>');
// new row for each record, with the proper fields
AddTableContents (Data);
// done
Add('</table>');
end;
procedure THtmlStrings.AddTableContents (Data: TDataSet);
var
Bookmark: TBookmark;
I: Integer;
begin
// disable the UI
Data.DisableControls;
try
// store the current position
Bookmark := Data.GetBookmark;
try
// scan the database table
Data.First;
while not Data.EOF do
begin
Add('<tr>'); // new row, with table data (tag <td>)
for I := 0 to Data.FieldCount - 1 do
if Data.Fields[I].Visible then
Add('<td>' + Data.Fields[I].DisplayText + '</td>');
Add('</tr>');
Data.Next;
end;
finally
// go back to the bookmark and destroy it
Data.GotoBookmark (Bookmark);
Data.FreeBookmark (Bookmark);
end;
finally
// re-enable the controls
Data.EnableControls;
end;
end;
end.
TABLESF.DFM
object MainForm: TMainForm
Left = 190
Top = 121
Width = 533
Height = 378
Caption = 'Tables Browser'
Font.Charset = DEFAULT_CHARSET
Font.Color = clBlack
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Splitter1: TSplitter
Left = 193
Top = 33
Width = 3
Height = 318
Cursor = crHSplit
Beveled = False
end
object ListBox1: TListBox
Left = 0
Top = 33
Width = 193
Height = 318
Align = alLeft
ItemHeight = 13
TabOrder = 0
OnClick = ListBox1Click
end
object Panel1: TPanel
Left = 0
Top = 0
Width = 525
Height = 33
Align = alTop
TabOrder = 1
object Label1: TLabel
Left = 8
Top = 8
Width = 49
Height = 13
Caption = '&Database:'
FocusControl = ComboBox1
end
object SpeedButton1: TSpeedButton
Left = 241
Top = 6
Width = 84
Height = 21
Caption = 'Set Fields...'
OnClick = SpeedButton1Click
end
object SpeedButton2: TSpeedButton
Left = 333
Top = 6
Width = 86
Height = 21
Caption = 'HTML Save...'
OnClick = SpeedButton2Click
end
object ComboBox1: TComboBox
Left = 61
Top = 5
Width = 172
Height = 21
ItemHeight = 13
TabOrder = 0
OnChange = ComboBox1Change
end
object CheckBox1: TCheckBox
Left = 432
Top = 8
Width = 65
Height = 17
Caption = 'Browser'
State = cbChecked
TabOrder = 1
end
end
object DBGrid1: TDBGrid
Left = 196
Top = 33
Width = 329
Height = 318
Align = alClient
DataSource = DataSource1
TabOrder = 2
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clBlack
TitleFont.Height = -11
TitleFont.Name = 'MS Sans Serif'
TitleFont.Style = []
end
object Table1: TTable
Left = 8
Top = 48
end
object DataSource1: TDataSource
DataSet = Table1
Left = 48
Top = 64
end
object SaveDialog1: TSaveDialog
DefaultExt = 'HTM'
Filter = 'HTML file (*.htm)|*.htm|Any file (*.*)|*.*'
Options = [ofOverwritePrompt, ofPathMustExist, ofCreatePrompt]
Left = 96
Top = 48
end
end
FIELDSF.DFM
object FieldsForm: TFieldsForm
Left = 209
Top = 113
Width = 422
Height = 302
Caption = 'FieldsForm'
Font.Charset = ANSI_CHARSET
Font.Color = clBlack
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object FieldsList: TListBox
Left = 0
Top = 49
Width = 414
Height = 226
Align = alClient
ExtendedSelect = False
ItemHeight = 13
MultiSelect = True
TabOrder = 0
end
object Panel1: TPanel
Left = 0
Top = 0
Width = 414
Height = 49
Align = alTop
TabOrder = 1
object Label1: TLabel
Left = 8
Top = 17
Width = 217
Height = 24
Caption = 'Select the fields you want to see in the grid'
WordWrap = True
end
object BitBtn1: TBitBtn
Left = 232
Top = 8
Width = 81
Height = 33
Caption = 'OK'
Default = True
ModalResult = 1
TabOrder = 0
Glyph.Data = {
DE010000424DDE01000000000000760000002800000024000000120000000100
0400000000006801000000000000000000001000000000000000000000000000
80000080000000808000800000008000800080800000C0C0C000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333
3333333333333333333333330000333333333333333333333333F33333333333
00003333344333333333333333388F3333333333000033334224333333333333
338338F3333333330000333422224333333333333833338F3333333300003342
222224333333333383333338F3333333000034222A22224333333338F338F333
8F33333300003222A3A2224333333338F3838F338F33333300003A2A333A2224
33333338F83338F338F33333000033A33333A222433333338333338F338F3333
0000333333333A222433333333333338F338F33300003333333333A222433333
333333338F338F33000033333333333A222433333333333338F338F300003333
33333333A222433333333333338F338F00003333333333333A22433333333333
3338F38F000033333333333333A223333333333333338F830000333333333333
333A333333333333333338330000333333333333333333333333333333333333
0000}
NumGlyphs = 2
end
object BitBtn2: TBitBtn
Left = 320
Top = 8
Width = 81
Height = 33
TabOrder = 1
Kind = bkCancel
end
end
end
Copyright Marco Cantù 1998