ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/employee/unit1.pas
Revision: 17
Committed: Sat Dec 28 19:22:24 2013 UTC (6 years, 6 months ago) by tony
File size: 6129 byte(s)
Log Message:
Committing updates for Release R1-0-5
Line File contents
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