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