examples/employee/unit1.pas

unit Unit1; 

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, DBGrids,
  StdCtrls, ActnList, IBDatabase, IBQuery, IBCustomDataSet, IBUpdateSQL, db;

type

  { TForm1 }

  TForm1 = class(TForm)
    CancelChanges: TAction;
    IBUpdateSQL1: TIBUpdateSQL;
    SaveChanges: TAction;
    DeleteEmployee: TAction;
    EditEmployee: TAction;
    AddEmployee: TAction;
    ActionList1: TActionList;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Datasource1: TDatasource;
    DBGrid1: TDBGrid;
    IBDatabase1: TIBDatabase;
    IBQuery1: TIBQuery;
    IBQuery1DEPT_NO: TIBStringField;
    IBQuery1EMP_NO: TSmallintField;
    IBQuery1FIRST_NAME: TIBStringField;
    IBQuery1FULL_NAME: TIBStringField;
    IBQuery1HIRE_DATE: TDateTimeField;
    IBQuery1JOB_CODE: TIBStringField;
    IBQuery1JOB_COUNTRY: TIBStringField;
    IBQuery1JOB_GRADE: TSmallintField;
    IBQuery1LAST_NAME: TIBStringField;
    IBQuery1PHONE_EXT: TIBStringField;
    IBQuery1SALARY: TIBBCDField;
    IBTransaction1: TIBTransaction;
    procedure AddEmployeeExecute(Sender: TObject);
    procedure CancelChangesExecute(Sender: TObject);
    procedure DBGrid1DblClick(Sender: TObject);
    procedure DeleteEmployeeExecute(Sender: TObject);
    procedure EditEmployeeExecute(Sender: TObject);
    procedure EditEmployeeUpdate(Sender: TObject);
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure IBDatabase1AfterConnect(Sender: TObject);
    procedure IBDatabase1BeforeDisconnect(Sender: TObject);
    procedure IBQuery1AfterDelete(DataSet: TDataSet);
    procedure IBQuery1AfterOpen(DataSet: TDataSet);
    procedure IBQuery1AfterTransactionEnd(Sender: TObject);
    procedure IBQuery1BeforeClose(DataSet: TDataSet);
    procedure IBQuery1BeforeOpen(DataSet: TDataSet);
    procedure IBQuery1PostError(DataSet: TDataSet; E: EDatabaseError;
      var DataAction: TDataAction);
    procedure IBQuery1SALARYGetText(Sender: TField; var aText: string;
      DisplayText: Boolean);
    procedure SaveChangesExecute(Sender: TObject);
    procedure SaveChangesUpdate(Sender: TObject);
  private
    { private declarations }
    FDirty: boolean;
    FClosing: boolean;
    FLastEmp_no: integer;
    procedure Reopen(Data: PtrInt);
  public
    { public declarations }
  end; 

var
  Form1: TForm1; 

implementation

{$R *.lfm}

uses Unit2, Unit3, IB;

function ExtractDBException(msg: string): string;
var Lines: TStringList;
begin
     Lines := TStringList.Create;
     try
       Lines.Text := msg;
       if pos('exception',Lines[0]) = 1 then
         Result := Lines[2]
       else
         Result := msg
     finally
       Lines.Free
     end;
end;

{ TForm1 }

procedure TForm1.IBQuery1SALARYGetText(Sender: TField; var aText: string;
  DisplayText: Boolean);
begin
  if DisplayText then
  begin
    if Sender.IsNUll then
      aText := ''
    else
      aText := FormatFloat('$#,##0.00',Sender.AsFloat)
  end
  else
    aText := Sender.AsString
end;

procedure TForm1.SaveChangesExecute(Sender: TObject);
begin
  IBQuery1.Transaction.Commit
end;

procedure TForm1.SaveChangesUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := FDirty
end;

procedure TForm1.Reopen(Data: PtrInt);
begin
  with IBTransaction1 do
    if not InTransaction then StartTransaction;
  IBQuery1.Active := true
end;

procedure TForm1.AddEmployeeExecute(Sender: TObject);
var NewEmpNo: integer;
begin
  if AddEmployeeDlg.ShowModal(NewEmpNo) = mrOK then
  begin
    FDirty := true;
    IBQuery1.Active := false;
    FLastEmp_no := NewEmpNo;
    IBQuery1.Active := true
  end;
end;

procedure TForm1.CancelChangesExecute(Sender: TObject);
begin
  IBQuery1.Transaction.Rollback
end;

procedure TForm1.DBGrid1DblClick(Sender: TObject);
begin
  if IBQuery1.Active and (IBQuery1.RecordCount > 0) then
    EditEmployeeExecute(nil)
end;

procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
begin
  if MessageDlg(
    Format('Remove %s from Employee List?',[IBQuery1.FieldByName('Full_Name').AsString]),
    mtConfirmation,[mbYes,mbNo],0) = mrYes then
    IBQuery1.Delete
end;

procedure TForm1.EditEmployeeExecute(Sender: TObject);
begin
  if EditEmployeeDlg.ShowModal(IBQuery1.FieldByName('Emp_No').AsInteger) = mrOK then
  begin
    FDirty := true;
    IBQuery1.Refresh
  end;
end;

procedure TForm1.EditEmployeeUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := IBQuery1.Active and (IBQuery1.RecordCount > 0)
end;

procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  FClosing := true
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  FLastEmp_no := -1;
  IBQuery1.Active := true
end;

procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
begin
  with IBTransaction1 do
    if not InTransaction then StartTransaction
end;

procedure TForm1.IBDatabase1BeforeDisconnect(Sender: TObject);
begin
  FClosing := true
end;

procedure TForm1.IBQuery1AfterDelete(DataSet: TDataSet);
begin
  FDirty := true
end;

procedure TForm1.IBQuery1AfterOpen(DataSet: TDataSet);
begin
  if FLastEmp_no <> -1 then
    DataSet.Locate('EMP_NO',FLastEmp_no,[])
end;

procedure TForm1.IBQuery1AfterTransactionEnd(Sender: TObject);
begin
  FDirty := false;
  if not FClosing then
    Application.QueueAsyncCall(@Reopen,0)
end;

procedure TForm1.IBQuery1BeforeClose(DataSet: TDataSet);
begin
  FLastEmp_no := DataSet.FieldByName('Emp_no').AsInteger
end;

procedure TForm1.IBQuery1BeforeOpen(DataSet: TDataSet);
begin
end;

procedure TForm1.IBQuery1PostError(DataSet: TDataSet; E: EDatabaseError;
  var DataAction: TDataAction);
begin
  if E is EIBError then
   begin
       MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
       DataSet.Cancel;
       DataAction  := daAbort
   end;
end;

end.

Revision:	17
Committed:	Sat Dec 28 19:22:24 2013 UTC (10 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	6129 byte(s)
Log Message:	Committing updates for Release R1-0-5
#	Content
1	unit Unit1;
2
3	{$mode objfpc}{$H+}
4
5	interface
6
7	uses
8	Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, DBGrids,
9	StdCtrls, ActnList, IBDatabase, IBQuery, IBCustomDataSet, IBUpdateSQL, db;
10
11	type
12
13	{ TForm1 }
14
15	TForm1 = class(TForm)
16	CancelChanges: TAction;
17	IBUpdateSQL1: TIBUpdateSQL;
18	SaveChanges: TAction;
19	DeleteEmployee: TAction;
20	EditEmployee: TAction;
21	AddEmployee: TAction;
22	ActionList1: TActionList;
23	Button1: TButton;
24	Button2: TButton;
25	Button3: TButton;
26	Button4: TButton;
27	Button5: TButton;
28	Datasource1: TDatasource;
29	DBGrid1: TDBGrid;
30	IBDatabase1: TIBDatabase;
31	IBQuery1: TIBQuery;
32	IBQuery1DEPT_NO: TIBStringField;
33	IBQuery1EMP_NO: TSmallintField;
34	IBQuery1FIRST_NAME: TIBStringField;
35	IBQuery1FULL_NAME: TIBStringField;
36	IBQuery1HIRE_DATE: TDateTimeField;
37	IBQuery1JOB_CODE: TIBStringField;
38	IBQuery1JOB_COUNTRY: TIBStringField;
39	IBQuery1JOB_GRADE: TSmallintField;
40	IBQuery1LAST_NAME: TIBStringField;
41	IBQuery1PHONE_EXT: TIBStringField;
42	IBQuery1SALARY: TIBBCDField;
43	IBTransaction1: TIBTransaction;
44	procedure AddEmployeeExecute(Sender: TObject);
45	procedure CancelChangesExecute(Sender: TObject);
46	procedure DBGrid1DblClick(Sender: TObject);
47	procedure DeleteEmployeeExecute(Sender: TObject);
48	procedure EditEmployeeExecute(Sender: TObject);
49	procedure EditEmployeeUpdate(Sender: TObject);
50	procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
51	procedure FormShow(Sender: TObject);
52	procedure IBDatabase1AfterConnect(Sender: TObject);
53	procedure IBDatabase1BeforeDisconnect(Sender: TObject);
54	procedure IBQuery1AfterDelete(DataSet: TDataSet);
55	procedure IBQuery1AfterOpen(DataSet: TDataSet);
56	procedure IBQuery1AfterTransactionEnd(Sender: TObject);
57	procedure IBQuery1BeforeClose(DataSet: TDataSet);
58	procedure IBQuery1BeforeOpen(DataSet: TDataSet);
59	procedure IBQuery1PostError(DataSet: TDataSet; E: EDatabaseError;
60	var DataAction: TDataAction);
61	procedure IBQuery1SALARYGetText(Sender: TField; var aText: string;
62	DisplayText: Boolean);
63	procedure SaveChangesExecute(Sender: TObject);
64	procedure SaveChangesUpdate(Sender: TObject);
65	private
66	{ private declarations }
67	FDirty: boolean;
68	FClosing: boolean;
69	FLastEmp_no: integer;
70	procedure Reopen(Data: PtrInt);
71	public
72	{ public declarations }
73	end;
74
75	var
76	Form1: TForm1;
77
78	implementation
79
80	{$R *.lfm}
81
82	uses Unit2, Unit3, IB;
83
84	function ExtractDBException(msg: string): string;
85	var Lines: TStringList;
86	begin
87	Lines := TStringList.Create;
88	try
89	Lines.Text := msg;
90	if pos('exception',Lines[0]) = 1 then
91	Result := Lines[2]
92	else
93	Result := msg
94	finally
95	Lines.Free
96	end;
97	end;
98
99	{ TForm1 }
100
101	procedure TForm1.IBQuery1SALARYGetText(Sender: TField; var aText: string;
102	DisplayText: Boolean);
103	begin
104	if DisplayText then
105	begin
106	if Sender.IsNUll then
107	aText := ''
108	else
109	aText := FormatFloat('$#,##0.00',Sender.AsFloat)
110	end
111	else
112	aText := Sender.AsString
113	end;
114
115	procedure TForm1.SaveChangesExecute(Sender: TObject);
116	begin
117	IBQuery1.Transaction.Commit
118	end;
119
120	procedure TForm1.SaveChangesUpdate(Sender: TObject);
121	begin
122	(Sender as TAction).Enabled := FDirty
123	end;
124
125	procedure TForm1.Reopen(Data: PtrInt);
126	begin
127	with IBTransaction1 do
128	if not InTransaction then StartTransaction;
129	IBQuery1.Active := true
130	end;
131
132	procedure TForm1.AddEmployeeExecute(Sender: TObject);
133	var NewEmpNo: integer;
134	begin
135	if AddEmployeeDlg.ShowModal(NewEmpNo) = mrOK then
136	begin
137	FDirty := true;
138	IBQuery1.Active := false;
139	FLastEmp_no := NewEmpNo;
140	IBQuery1.Active := true
141	end;
142	end;
143
144	procedure TForm1.CancelChangesExecute(Sender: TObject);
145	begin
146	IBQuery1.Transaction.Rollback
147	end;
148
149	procedure TForm1.DBGrid1DblClick(Sender: TObject);
150	begin
151	if IBQuery1.Active and (IBQuery1.RecordCount > 0) then
152	EditEmployeeExecute(nil)
153	end;
154
155	procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
156	begin
157	if MessageDlg(
158	Format('Remove %s from Employee List?',[IBQuery1.FieldByName('Full_Name').AsString]),
159	mtConfirmation,[mbYes,mbNo],0) = mrYes then
160	IBQuery1.Delete
161	end;
162
163	procedure TForm1.EditEmployeeExecute(Sender: TObject);
164	begin
165	if EditEmployeeDlg.ShowModal(IBQuery1.FieldByName('Emp_No').AsInteger) = mrOK then
166	begin
167	FDirty := true;
168	IBQuery1.Refresh
169	end;
170	end;
171
172	procedure TForm1.EditEmployeeUpdate(Sender: TObject);
173	begin
174	(Sender as TAction).Enabled := IBQuery1.Active and (IBQuery1.RecordCount > 0)
175	end;
176
177	procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
178	begin
179	FClosing := true
180	end;
181
182	procedure TForm1.FormShow(Sender: TObject);
183	begin
184	FLastEmp_no := -1;
185	IBQuery1.Active := true
186	end;
187
188	procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
189	begin
190	with IBTransaction1 do
191	if not InTransaction then StartTransaction
192	end;
193
194	procedure TForm1.IBDatabase1BeforeDisconnect(Sender: TObject);
195	begin
196	FClosing := true
197	end;
198
199	procedure TForm1.IBQuery1AfterDelete(DataSet: TDataSet);
200	begin
201	FDirty := true
202	end;
203
204	procedure TForm1.IBQuery1AfterOpen(DataSet: TDataSet);
205	begin
206	if FLastEmp_no <> -1 then
207	DataSet.Locate('EMP_NO',FLastEmp_no,[])
208	end;
209
210	procedure TForm1.IBQuery1AfterTransactionEnd(Sender: TObject);
211	begin
212	FDirty := false;
213	if not FClosing then
214	Application.QueueAsyncCall(@Reopen,0)
215	end;
216
217	procedure TForm1.IBQuery1BeforeClose(DataSet: TDataSet);
218	begin
219	FLastEmp_no := DataSet.FieldByName('Emp_no').AsInteger
220	end;
221
222	procedure TForm1.IBQuery1BeforeOpen(DataSet: TDataSet);
223	begin
224	end;
225
226	procedure TForm1.IBQuery1PostError(DataSet: TDataSet; E: EDatabaseError;
227	var DataAction: TDataAction);
228	begin
229	if E is EIBError then
230	begin
231	MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
232	DataSet.Cancel;
233	DataAction := daAbort
234	end;
235	end;
236
237	end.
238