ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/employee/unit1.pas
Revision: 21
Committed: Thu Feb 26 10:33:34 2015 UTC (9 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 10560 byte(s)
Log Message:
Committing updates for Release R1-2-0

File Contents

# 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, EditBtn, DbCtrls, ExtCtrls, Buttons, IBDatabase, IBQuery,
10 IBCustomDataSet, IBUpdateSQL, IBDynamicGrid, IBLookupComboEditBox,
11 db, DBExtCtrls;
12
13 type
14
15 { TForm1 }
16
17 TForm1 = class(TForm)
18 DBEdit6: TDBEdit;
19 EmployeesDEPT_KEY_PATH: TIBStringField;
20 EmployeesDEPT_PATH: TIBStringField;
21 IBLookupComboEditBox1: TIBLookupComboEditBox;
22 IBLookupComboEditBox2: TIBLookupComboEditBox;
23 SelectDept: TAction;
24 Button4: TButton;
25 Button5: TButton;
26 CancelChanges: TAction;
27 SalaryRange: TComboBox;
28 CountrySource: TDataSource;
29 BeforeDate: TDateEdit;
30 AfterDate: TDateEdit;
31 DeptsSource: TDataSource;
32 Depts: TIBQuery;
33 JobCodeSource: TDataSource;
34 DBEdit1: TDBEdit;
35 DBEdit2: TDBEdit;
36 DBEdit3: TDBEdit;
37 DBEdit4: TDBEdit;
38 DBEdit5: TDBEdit;
39 DBText1: TDBText;
40 Employees: TIBDataSet;
41 EmployeesDEPT_NO: TIBStringField;
42 EmployeesEMP_NO: TSmallintField;
43 EmployeesFIRST_NAME: TIBStringField;
44 EmployeesFULL_NAME: TIBStringField;
45 EmployeesHIRE_DATE: TDateTimeField;
46 EmployeesJOB_CODE: TIBStringField;
47 EmployeesJOB_COUNTRY: TIBStringField;
48 EmployeesJOB_GRADE: TSmallintField;
49 EmployeesLAST_NAME: TIBStringField;
50 EmployeesPHONE_EXT: TIBStringField;
51 EmployeesSALARY: TIBBCDField;
52 IBDateEdit1: TDBDateEdit;
53 IBDynamicGrid1: TIBDynamicGrid;
54 Countries: TIBQuery;
55 JobCodes: TIBQuery;
56 JobGradeDBComboBox: TDBComboBox;
57 Label10: TLabel;
58 Label11: TLabel;
59 Label12: TLabel;
60 Label13: TLabel;
61 Label3: TLabel;
62 Label4: TLabel;
63 Label5: TLabel;
64 Label6: TLabel;
65 Label7: TLabel;
66 Label8: TLabel;
67 Label9: TLabel;
68 Panel1: TPanel;
69 Panel2: TPanel;
70 EmployeeEditorPanel: TPanel;
71 SpeedButton1: TSpeedButton;
72 TotalsQueryTOTALSALARIES: TIBBCDField;
73 TotalsSource: TDataSource;
74 TotalsQuery: TIBQuery;
75 Label1: TLabel;
76 Label2: TLabel;
77 SaveChanges: TAction;
78 DeleteEmployee: TAction;
79 EditEmployee: TAction;
80 AddEmployee: TAction;
81 ActionList1: TActionList;
82 Button1: TButton;
83 Button2: TButton;
84 Button3: TButton;
85 EmployeeSource: TDataSource;
86 IBDatabase1: TIBDatabase;
87 IBTransaction1: TIBTransaction;
88 procedure EmployeesAfterPost(DataSet: TDataSet);
89 procedure JobGradeDBComboBoxCloseUp(Sender: TObject);
90 procedure SelectDeptExecute(Sender: TObject);
91 procedure AddEmployeeExecute(Sender: TObject);
92 procedure BeforeDateChange(Sender: TObject);
93 procedure CancelChangesExecute(Sender: TObject);
94 procedure CountriesBeforeOpen(DataSet: TDataSet);
95 procedure DeleteEmployeeExecute(Sender: TObject);
96 procedure EditEmployeeExecute(Sender: TObject);
97 procedure EditEmployeeUpdate(Sender: TObject);
98 procedure EmployeesAfterInsert(DataSet: TDataSet);
99 procedure EmployeesAfterOpen(DataSet: TDataSet);
100 procedure EmployeesAfterScroll(DataSet: TDataSet);
101 procedure EmployeesBeforeClose(DataSet: TDataSet);
102 procedure EmployeesBeforeOpen(DataSet: TDataSet);
103 procedure EmployeesJOB_CODEChange(Sender: TField);
104 procedure EmployeesJOB_GRADEChange(Sender: TField);
105 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
106 procedure FormShow(Sender: TObject);
107 procedure EmployeesAfterDelete(DataSet: TDataSet);
108 procedure EmployeesAfterTransactionEnd(Sender: TObject);
109 procedure EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
110 var DataAction: TDataAction);
111 procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
112 DisplayText: Boolean);
113 procedure JobCodesBeforeOpen(DataSet: TDataSet);
114 procedure SaveChangesExecute(Sender: TObject);
115 procedure SaveChangesUpdate(Sender: TObject);
116 private
117 { private declarations }
118 FDirty: boolean;
119 FClosing: boolean;
120 procedure Reopen(Data: PtrInt);
121 public
122 { public declarations }
123 end;
124
125 var
126 Form1: TForm1;
127
128 implementation
129
130 {$R *.lfm}
131
132 uses IB, Unit2;
133
134 function ExtractDBException(msg: string): string;
135 var Lines: TStringList;
136 begin
137 Lines := TStringList.Create;
138 try
139 Lines.Text := msg;
140 if pos('exception',Lines[0]) = 1 then
141 Result := Lines[2]
142 else
143 Result := msg
144 finally
145 Lines.Free
146 end;
147 end;
148
149 { TForm1 }
150
151 procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
152 DisplayText: Boolean);
153 begin
154 if DisplayText then
155 begin
156 if Sender.IsNUll then
157 aText := ''
158 else
159 aText := FormatFloat('$#,##0.00',Sender.AsFloat)
160 end
161 else
162 aText := Sender.AsString
163 end;
164
165 procedure TForm1.JobCodesBeforeOpen(DataSet: TDataSet);
166 begin
167 JobCodes.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
168 JobCodes.ParamByName('JOB_COUNTRY').AsString := EmployeesJOB_COUNTRY.AsString
169 end;
170
171 procedure TForm1.SaveChangesExecute(Sender: TObject);
172 begin
173 Employees.Transaction.Commit
174 end;
175
176 procedure TForm1.SaveChangesUpdate(Sender: TObject);
177 begin
178 (Sender as TAction).Enabled := FDirty
179 end;
180
181 procedure TForm1.Reopen(Data: PtrInt);
182 begin
183 with IBTransaction1 do
184 if not InTransaction then StartTransaction;
185 Countries.Active := true;
186 Employees.Active := true;
187 JobCodes.Active := true;
188 Depts.Active := true;
189 end;
190
191 procedure TForm1.AddEmployeeExecute(Sender: TObject);
192 begin
193 Employees.Append
194 end;
195
196 procedure TForm1.SelectDeptExecute(Sender: TObject);
197 var Dept_No: string;
198 begin
199 if SelectDeptDlg.ShowModal(EmployeesDEPT_KEY_PATH.AsString,Dept_No) = mrOK then
200 begin
201 Employees.Edit;
202 EmployeesDEPT_NO.AsString := Dept_No;
203 try
204 Employees.Post;
205 except
206 Employees.Cancel;
207 raise;
208 end;
209 IBDynamicGrid1.ShowEditorPanel;
210 end;
211 end;
212
213 procedure TForm1.EmployeesAfterPost(DataSet: TDataSet);
214 begin
215 Employees.Refresh
216 end;
217
218 procedure TForm1.JobGradeDBComboBoxCloseUp(Sender: TObject);
219 begin
220 JobGradeDBComboBox.EditingDone; //See http://bugs.freepascal.org/view.php?id=27186
221 end;
222
223 procedure TForm1.BeforeDateChange(Sender: TObject);
224 begin
225 Employees.Active := false;
226 Employees.Active := true
227 end;
228
229 procedure TForm1.CancelChangesExecute(Sender: TObject);
230 begin
231 Employees.Transaction.Rollback
232 end;
233
234 procedure TForm1.CountriesBeforeOpen(DataSet: TDataSet);
235 begin
236 Countries.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
237 Countries.ParamByName('JOB_CODE').AsString := EmployeesJOB_CODE.AsString
238 end;
239
240 procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
241 begin
242 if MessageDlg(
243 Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
244 mtConfirmation,[mbYes,mbNo],0) = mrYes then
245 Employees.Delete
246 end;
247
248 procedure TForm1.EditEmployeeExecute(Sender: TObject);
249 begin
250 IBDynamicGrid1.ShowEditorPanel;
251 end;
252
253 procedure TForm1.EditEmployeeUpdate(Sender: TObject);
254 begin
255 (Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
256 end;
257
258 procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
259 begin
260 EmployeesJOB_COUNTRY.AsString := 'USA';
261 EmployeesJOB_CODE.AsString := 'SRep';
262 EmployeesJOB_GRADE.AsInteger := 4;
263 EmployeesSALARY.AsCurrency := 20000;
264 EmployeesFIRST_NAME.AsString := '<no name>';
265 EmployeesLAST_NAME.AsString := '<no name>';
266 EmployeesHIRE_DATE.AsDateTime := now;
267 EmployeesDEPT_NO.AsString := '000';
268 FDirty := true;
269 end;
270
271 procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
272 begin
273 TotalsQuery.Active := true
274 end;
275
276 procedure TForm1.EmployeesAfterScroll(DataSet: TDataSet);
277 begin
278 Countries.Active := false;
279 JobCodes.Active := false;
280 Countries.Active := true;
281 JobCodes.Active := true;
282 end;
283
284 procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
285 begin
286 with DataSet do
287 if State in [dsInsert,dsEdit] then
288 try
289 Post;
290 except
291 Cancel;
292 raise;
293 end;
294 TotalsQuery.Active := false
295 end;
296
297 procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
298 begin
299 if BeforeDate.Date > 0 then
300 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE < :BeforeDate');
301 if AfterDate.Date > 0 then
302 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE > :AfterDate');
303
304 case SalaryRange.ItemIndex of
305 1:
306 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary < 40000');
307 2:
308 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 40000 and Salary < 100000');
309 3:
310 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 100000');
311 end;
312
313
314
315 {Parameter value must be set after all SQL changes have been made}
316 if BeforeDate.Date > 0 then
317 (DataSet as TIBParserDataSet).ParamByName('BeforeDate').AsDateTime := BeforeDate.Date;
318 if AfterDate.Date > 0 then
319 (DataSet as TIBParserDataSet).ParamByName('AfterDate').AsDateTime := AfterDate.Date;
320
321 end;
322
323 procedure TForm1.EmployeesJOB_CODEChange(Sender: TField);
324 begin
325 Countries.Active := false;
326 Countries.Active := true;
327 end;
328
329 procedure TForm1.EmployeesJOB_GRADEChange(Sender: TField);
330 begin
331 Countries.Active := false;
332 JobCodes.Active := false;
333 Countries.Active := true;
334 JobCodes.Active := true;
335 end;
336
337 procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
338 begin
339 FClosing := true;
340 if IBTransaction1.InTransaction then
341 IBTransaction1.Commit;
342 end;
343
344 procedure TForm1.FormShow(Sender: TObject);
345 begin
346 repeat
347 try
348 IBDatabase1.Connected := true;
349 except
350 on E:EIBClientError do
351 begin
352 Close;
353 Exit
354 end;
355 On E:Exception do
356 MessageDlg(E.Message,mtError,[mbOK],0);
357 end;
358 until IBDatabase1.Connected;
359 Reopen(0);
360 end;
361
362 procedure TForm1.EmployeesAfterDelete(DataSet: TDataSet);
363 begin
364 FDirty := true
365 end;
366
367 procedure TForm1.EmployeesAfterTransactionEnd(Sender: TObject);
368 begin
369 FDirty := false;
370 if not FClosing then
371 Application.QueueAsyncCall(@Reopen,0)
372 end;
373
374 procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
375 var DataAction: TDataAction);
376 begin
377 if E is EIBError then
378 begin
379 MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
380 DataSet.Cancel;
381 DataAction := daAbort
382 end;
383 end;
384
385 end.
386