Marco Cantù 1998, Mastering Delphi 4
Project: CREATEG.DPR
Project Structure
CREATEG.DPR
program Createg;
uses
Forms,
GraphF in 'GraphF.pas' {GraphForm},
TablesF in 'TablesF.pas' {TablesForm};
{$R *.RES}
begin
Application.CreateForm(TGraphForm, GraphForm);
Application.Run;
end.
GRAPHF.PAS
unit GraphF;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics,
Controls, StdCtrls, Forms, DBCtrls, DB, DBTables, ExtCtrls,
Mask, Buttons, Dialogs, TablesF, Menus;
type
EMyDatabaseError = class (EDatabaseError) end;
TGraphForm = class(TForm)
ScrollBox: TScrollBox;
Label1: TLabel;
EditDescription: TDBEdit;
Label3: TLabel;
EditDate: TDBEdit;
Label4: TLabel;
DBImage: TDBImage;
Panel1: TPanel;
DataSource1: TDataSource;
Table1: TTable;
SpeedAdd: TSpeedButton;
SpeedDelete: TSpeedButton;
Table2: TTable;
CheckBox1: TCheckBox;
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
N2: TMenuItem;
Open1: TMenuItem;
New1: TMenuItem;
Help1: TMenuItem;
About1: TMenuItem;
DBNavigator: TDBNavigator;
SpeedOpen: TSpeedButton;
SpeedNew: TSpeedButton;
Record1: TMenuItem;
Add1: TMenuItem;
Delete1: TMenuItem;
procedure FormCreate(Sender: TObject);
procedure CheckBox1Click(Sender: TObject);
procedure New1Click(Sender: TObject);
procedure Open1Click(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure About1Click(Sender: TObject);
procedure Add1Click(Sender: TObject);
procedure Delete1Click(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
GraphForm: TGraphForm;
implementation
{$R *.DFM}
procedure TGraphForm.FormCreate(Sender: TObject);
var
Code: Word;
Done: Boolean;
begin
Done := False;
while not Done do
try
Code := MessageDlg (
'Do you want to create a new table?' +
#13'(choose No to load an existing table,' +
#13'Cancel to quit)',
mtConfirmation, mbYesNoCancel, 0);
if Code = idYes then
New1Click (self)
else if Code = idNo then
Open1Click (self)
else
Application.Terminate;
Done := True;
except
on E: EMyDatabaseError do
ShowMessage (E.Message);
end; // end of try-except and while blocks
end;
procedure TGraphForm.CheckBox1Click(Sender: TObject);
begin
DBImage.Stretch := CheckBox1.Checked;
end;
procedure TGraphForm.New1Click(Sender: TObject);
var
TableName: string;
TbNames: TStringList;
begin
{request the name of the new table to the user,
raising an expcetion in case Cancel is pressed}
TableName := '';
if InputQuery ('New Table',
'Enter a new table name:', TableName) then
begin
if TableName = '' then
raise EMyDatabaseError.Create (
'Invalid table name');
{if the table already exists in the DBDEMOS
database, do not overwrite it}
TbNames := TStringList.Create;
try
Session.GetTableNames ('DBDEMOS', '',
False, False, TbNames);
if TbNames.IndexOf (TableName) >= 0 then
raise EMyDatabaseError.Create (
'Table already exists');
finally
TbNames.Free;
end;
{close the current table}
Table1.Close;
{set the name and type of the new table}
Table1.TableName := TableName;
Table1.TableType := ttParadox;
{define the three fields and the index}
with Table1.FieldDefs do
begin
Clear;
Add ('Description', ftString, 50, True);
Add ('Time', ftDateTime, 0, False);
Add ('Graphics', ftGraphic, 0, False);
end;
Table1.IndexDefs.Clear;
Table1.IndexDefs.Add('DescrIndex', 'Description',
[ixPrimary, ixUnique]);
{create the table using the above definitions}
Table1.CreateTable;
Table1.Open;
Caption := 'Create Graphics - ' + TableName;
end
else // if InputQuery
// if OnCreate called this methods
if Sender = self then
raise EMyDatabaseError.Create (
'Table creation aborted by the user');
end;
procedure TGraphForm.Open1Click(Sender: TObject);
var
TbNames: TStringList;
I: Integer;
TableFound: Boolean;
begin
{create the form of the dialog box,
before filling its list box with the table names}
TablesForm := TTablesForm.Create (Application);
{retrieve the list of tables from the database}
TableFound := False;
TbNames := TStringList.Create;
try
Session.GetTableNames ('DBDEMOS', '',
True, False, TbNames);
{checks if the table has the proper fields,
that is, if it was created by this program.
The code uses a secondary table object}
for I := 0 to TbNames.Count - 1 do
begin
Table2.TableName := TbNames [I];
Table2.FieldDefs.Update;
if (Table2.FieldDefs.Count = 3) and
(Table2.FieldDefs[0].DataType = ftString) and
(Table2.FieldDefs[1].DataType = ftDateTime) and
(Table2.FieldDefs[2].DataType = ftGraphic) then
begin
{table fields match: add the table to the list}
TablesForm.Listbox1.Items.Add (Table2.TableName);
TableFound := True;
end;
end;
finally
TBNames.Free;
end;
{if no table was found, raise an exception}
if not TableFound then
raise EMyDatabaseError.Create (
'No table with the proper structure');
{otherwise, show the dialog box}
TablesForm.ListBox1.ItemIndex := 0;
if TablesForm.ShowModal = idOK then
begin
{if OK was pressed, open the table}
Table1.Close;
Table1.TableName := TablesForm.ListBox1.Items [
TablesForm.ListBox1.ItemIndex];
Table1.Open;
Caption := 'Create Graphics - ' +
Table1.TableName;
end
else
// if OnCreate called this methods
if Sender = self then
raise EMyDatabaseError.Create (
'Table selection aborted by the user');
end;
procedure TGraphForm.Exit1Click(Sender: TObject);
begin
Close;
end;
procedure TGraphForm.About1Click(Sender: TObject);
begin
MessageDlg ('CreateG example, from the book' +
#13'"Mastering Delphi", by Marco Cantù',
mtInformation, [mbOK], 0);
end;
procedure TGraphForm.Add1Click(Sender: TObject);
var
Descr: string;
begin
if InputQuery ('New record',
'Enter the description:', Descr) then
begin
Table1.Insert;
EditDescription.Text := Descr;
EditDate.Text := DateTimeToStr (Now);
DBIMage.PasteFromClipboard;
Table1.Post;
end;
end;
procedure TGraphForm.Delete1Click(Sender: TObject);
begin
if MessageDlg (
'Are you sure you want to delete the current record?',
mtConfirmation, [mbYes, mbNo], 0) = idYes then
Table1.Delete;
end;
end.
TABLESF.PAS
unit TablesF;
interface
uses
SysUtils, Windows, Messages, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, Buttons;
type
TTablesForm = class(TForm)
ListBox1: TListBox;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
private
{ Private declarations }
public
{ Public declarations }
end;
var
TablesForm: TTablesForm;
implementation
{$R *.DFM}
end.
GRAPHF.DFM
object GraphForm: TGraphForm
Left = 278
Top = 121
Width = 472
Height = 402
ActiveControl = Panel1
Caption = 'Create Graphic'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clBlack
Font.Height = -11
Font.Name = 'Arial'
Font.Style = []
Menu = MainMenu1
OldCreateOrder = True
Position = poScreenCenter
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 14
object Panel1: TPanel
Left = 0
Top = 0
Width = 464
Height = 42
Align = alTop
TabOrder = 0
object SpeedAdd: TSpeedButton
Left = 138
Top = 8
Width = 65
Height = 25
Caption = 'Add...'
Flat = True
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
04000000000000010000120B0000120B00001000000000000000000000000000
800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00555555555555
55555555FFFFFFFF5555555000000005555555577777777FF555550999999900
55555575555555775F55509999999901055557F55555557F75F5001111111101
105577FFFFFFFF7FF75F00000000000011057777777777775F755070FFFFFF0F
01105777F555557F75F75500FFFFFF0FF0105577F555FF7F57575550FF700008
8F0055575FF7777555775555000888888F005555777FFFFFFF77555550000000
0F055555577777777F7F555550FFFFFF0F05555557F5FFF57F7F555550F000FF
0005555557F777557775555550FFFFFF0555555557F555FF7F55555550FF7000
05555555575FF777755555555500055555555555557775555555}
NumGlyphs = 2
OnClick = Add1Click
end
object SpeedDelete: TSpeedButton
Left = 203
Top = 8
Width = 65
Height = 25
Caption = 'Delete'
Flat = True
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
04000000000000010000120B0000120B00001000000000000000000000000000
800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00555555555555
55555FFFFFFF5F55FFF5777777757559995777777775755777F7555555555550
305555555555FF57F7F555555550055BB0555555555775F777F55555550FB000
005555555575577777F5555550FB0BF0F05555555755755757F555550FBFBF0F
B05555557F55557557F555550BFBF0FB005555557F55575577F555500FBFBFB0
B05555577F555557F7F5550E0BFBFB00B055557575F55577F7F550EEE0BFB0B0
B05557FF575F5757F7F5000EEE0BFBF0B055777FF575FFF7F7F50000EEE00000
B0557777FF577777F7F500000E055550805577777F7555575755500000555555
05555777775555557F5555000555555505555577755555557555}
NumGlyphs = 2
OnClick = Delete1Click
end
object SpeedOpen: TSpeedButton
Left = 73
Top = 8
Width = 65
Height = 25
Caption = 'Open...'
Flat = True
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
04000000000000010000120B0000120B00001000000000000000000000000000
800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00555555555555
5555555555555555555555555555555555555555555555555555555555555555
555555555555555555555555555555555555555FFFFFFFFFF555550000000000
55555577777777775F55500B8B8B8B8B05555775F555555575F550F0B8B8B8B8
B05557F75F555555575F50BF0B8B8B8B8B0557F575FFFFFFFF7F50FBF0000000
000557F557777777777550BFBFBFBFB0555557F555555557F55550FBFBFBFBF0
555557F555555FF7555550BFBFBF00055555575F555577755555550BFBF05555
55555575FFF75555555555700007555555555557777555555555555555555555
5555555555555555555555555555555555555555555555555555}
NumGlyphs = 2
OnClick = Open1Click
end
object SpeedNew: TSpeedButton
Left = 8
Top = 8
Width = 65
Height = 25
Caption = 'New...'
Flat = True
Glyph.Data = {
76010000424D7601000000000000760000002800000020000000100000000100
04000000000000010000120B0000120B00001000000000000000000000000000
800000800000008080008000000080008000808000007F7F7F00BFBFBF000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00555555555555
55555555FFFFFFFF5555555000000005555555577777777FF555550999999900
55555575555555775F55509999999901055557F55555557F75F5001111111101
105577FFFFFFFF7FF75F00000000000011057777777777775F755070FFFFFF0F
01105777F555557F7FF75500FFFFFF0F00105577F555FF7F77575550FF70000F
0F0055575FF777757F775555000FFFFF0F005555777555FF7F77555550FF7000
0F055555575FF777757F555555000FFFFF05555555777555FF7F55555550FF70
0005555555575FF7777555555555000555555555555577755555555555555555
5555555555555555555555555555555555555555555555555555}
NumGlyphs = 2
OnClick = New1Click
end
object DBNavigator: TDBNavigator
Left = 268
Top = 8
Width = 188
Height = 25
DataSource = DataSource1
VisibleButtons = [nbFirst, nbPrior, nbNext, nbLast]
Flat = True
TabOrder = 0
end
end
object ScrollBox: TScrollBox
Left = 0
Top = 42
Width = 464
Height = 314
Align = alClient
BorderStyle = bsNone
TabOrder = 1
object Label1: TLabel
Left = 3
Top = 5
Width = 61
Height = 14
Alignment = taRightJustify
AutoSize = False
Caption = 'Description'
FocusControl = EditDescription
end
object Label3: TLabel
Left = 3
Top = 29
Width = 62
Height = 14
Alignment = taRightJustify
AutoSize = False
Caption = 'Date/Time'
FocusControl = EditDate
end
object Label4: TLabel
Left = 27
Top = 54
Width = 34
Height = 14
Alignment = taRightJustify
AutoSize = False
Caption = 'Image'
FocusControl = DBImage
end
object EditDescription: TDBEdit
Left = 72
Top = 3
Width = 256
Height = 22
DataField = 'Description'
DataSource = DataSource1
MaxLength = 100
TabOrder = 0
end
object EditDate: TDBEdit
Left = 72
Top = 27
Width = 256
Height = 22
DataField = 'Time'
DataSource = DataSource1
MaxLength = 100
TabOrder = 1
end
object DBImage: TDBImage
Left = 72
Top = 51
Width = 385
Height = 254
Center = False
DataField = 'Graphics'
DataSource = DataSource1
Stretch = True
TabOrder = 2
end
object CheckBox1: TCheckBox
Left = 392
Top = 24
Width = 65
Height = 17
Caption = 'Stretch'
Checked = True
State = cbChecked
TabOrder = 3
OnClick = CheckBox1Click
end
end
object DataSource1: TDataSource
DataSet = Table1
Left = 8
Top = 184
end
object Table1: TTable
DatabaseName = 'DBDEMOS'
Left = 8
Top = 136
end
object Table2: TTable
DatabaseName = 'DBDEMOS'
Left = 8
Top = 298
end
object MainMenu1: TMainMenu
Left = 8
Top = 242
object File1: TMenuItem
Caption = '&File'
object New1: TMenuItem
Caption = '&New...'
OnClick = New1Click
end
object Open1: TMenuItem
Caption = '&Open...'
OnClick = Open1Click
end
object N2: TMenuItem
Caption = '-'
end
object Exit1: TMenuItem
Caption = 'E&xit'
OnClick = Exit1Click
end
end
object Record1: TMenuItem
Caption = '&Record'
object Add1: TMenuItem
Caption = '&Add...'
OnClick = Add1Click
end
object Delete1: TMenuItem
Caption = '&Delete'
OnClick = Delete1Click
end
end
object Help1: TMenuItem
Caption = '&Help'
object About1: TMenuItem
Caption = '&About...'
OnClick = About1Click
end
end
end
end
TABLESF.DFM
object TablesForm: TTablesForm
Left = 238
Top = 120
BorderStyle = bsDialog
Caption = 'Tables'
ClientHeight = 198
ClientWidth = 178
Font.Color = clBlack
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
PixelsPerInch = 96
TextHeight = 13
object ListBox1: TListBox
Left = 0
Top = 0
Width = 177
Height = 161
ItemHeight = 13
TabOrder = 0
end
object BitBtn1: TBitBtn
Left = 8
Top = 168
Width = 73
Height = 25
TabOrder = 1
Kind = bkOK
end
object BitBtn2: TBitBtn
Left = 96
Top = 168
Width = 73
Height = 25
TabOrder = 2
Kind = bkCancel
end
end
Copyright Marco Cantù 1998