ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/employee/unit1.pas
Revision: 33
Committed: Sat Jul 18 12:30:52 2015 UTC (9 years, 4 months ago) by tony
Content type: text/x-pascal
File size: 11231 byte(s)
Log Message:
Committing updates for Release R1-3-1

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