ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/local-employeedb/unit1.pas
Revision: 107
Committed: Thu Jan 18 14:37:40 2018 UTC (6 years, 10 months ago) by tony
Content type: text/x-pascal
File size: 14451 byte(s)
Log Message:
Fixes merged

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, IBSQL, IBDynamicGrid, IBLookupComboEditBox,
11 IBLocalDBSupport, db, DBExtCtrls, Menus;
12
13 const
14 RequiredVersionNo = 2;
15
16 type
17
18 { TForm1 }
19
20 TForm1 = class(TForm)
21 CheckVersionTablePresent: TIBSQL;
22 DBImage1: TDBImage;
23 EmployeesPHOTO1: TBlobField;
24 GetDBVersionNoQuery: TIBSQL;
25 MenuItem6: TMenuItem;
26 MenuItem7: TMenuItem;
27 Panel3: TPanel;
28 Quit: TAction;
29 MainMenu1: TMainMenu;
30 MenuItem1: TMenuItem;
31 MenuItem2: TMenuItem;
32 MenuItem3: TMenuItem;
33 MenuItem4: TMenuItem;
34 MenuItem5: TMenuItem;
35 RestoreDatabase: TAction;
36 SaveDatabase: TAction;
37 NewDatabase: TAction;
38 DBEdit6: TDBEdit;
39 EmployeesDEPT_KEY_PATH: TIBStringField;
40 EmployeesDEPT_PATH: TIBStringField;
41 IBLocalDBSupport1: TIBLocalDBSupport;
42 IBLookupComboEditBox1: TIBLookupComboEditBox;
43 IBLookupComboEditBox2: TIBLookupComboEditBox;
44 IBQuery1DEPT_NO: TIBStringField;
45 IBQuery1EMP_NO: TSmallintField;
46 IBQuery1FIRST_NAME: TIBStringField;
47 IBQuery1FULL_NAME: TIBStringField;
48 IBQuery1HIRE_DATE: TDateTimeField;
49 IBQuery1JOB_CODE: TIBStringField;
50 IBQuery1JOB_COUNTRY: TIBStringField;
51 IBQuery1JOB_GRADE: TSmallintField;
52 IBQuery1LAST_NAME: TIBStringField;
53 IBQuery1PHONE_EXT: TIBStringField;
54 IBQuery1SALARY: TIBBCDField;
55 SelectDept: TAction;
56 Button4: TButton;
57 Button5: TButton;
58 CancelChanges: TAction;
59 SalaryRange: TComboBox;
60 CountrySource: TDataSource;
61 BeforeDate: TDateEdit;
62 AfterDate: TDateEdit;
63 DeptsSource: TDataSource;
64 Depts: TIBQuery;
65 JobCodeSource: TDataSource;
66 DBEdit1: TDBEdit;
67 DBEdit2: TDBEdit;
68 DBEdit3: TDBEdit;
69 DBEdit4: TDBEdit;
70 DBEdit5: TDBEdit;
71 DBText1: TDBText;
72 Employees: TIBDataSet;
73 EmployeesDEPT_NO: TIBStringField;
74 EmployeesEMP_NO: TSmallintField;
75 EmployeesFIRST_NAME: TIBStringField;
76 EmployeesFULL_NAME: TIBStringField;
77 EmployeesHIRE_DATE: TDateTimeField;
78 EmployeesJOB_CODE: TIBStringField;
79 EmployeesJOB_COUNTRY: TIBStringField;
80 EmployeesJOB_GRADE: TSmallintField;
81 EmployeesLAST_NAME: TIBStringField;
82 EmployeesPHONE_EXT: TIBStringField;
83 EmployeesSALARY: TIBBCDField;
84 IBDateEdit1: TDBDateEdit;
85 IBDynamicGrid1: TIBDynamicGrid;
86 Countries: TIBQuery;
87 JobCodes: TIBQuery;
88 JobGradeDBComboBox: TDBComboBox;
89 Label10: TLabel;
90 Label11: TLabel;
91 Label12: TLabel;
92 Label13: TLabel;
93 Label3: TLabel;
94 Label4: TLabel;
95 Label5: TLabel;
96 Label6: TLabel;
97 Label7: TLabel;
98 Label8: TLabel;
99 Label9: TLabel;
100 Panel1: TPanel;
101 Panel2: TPanel;
102 EmployeeEditorPanel: TPanel;
103 SpeedButton1: TSpeedButton;
104 JobGradeChangeTimer: TTimer;
105 JobCodeChangeTimer: TTimer;
106 TotalsQueryTOTALSALARIES: TIBBCDField;
107 TotalsSource: TDataSource;
108 TotalsQuery: TIBQuery;
109 Label1: TLabel;
110 Label2: TLabel;
111 SaveChanges: TAction;
112 DeleteEmployee: TAction;
113 EditEmployee: TAction;
114 AddEmployee: TAction;
115 ActionList1: TActionList;
116 Button1: TButton;
117 Button2: TButton;
118 Button3: TButton;
119 EmployeeSource: TDataSource;
120 IBDatabase1: TIBDatabase;
121 IBTransaction1: TIBTransaction;
122 procedure DBImage1DBImageRead(Sender: TObject; S: TStream;
123 var GraphExt: string);
124 procedure EmployeesValidatePost(Sender: TObject; var CancelPost: boolean);
125 procedure IBDatabase1AfterConnect(Sender: TObject);
126 procedure IBLocalDBSupport1GetDBVersionNo(Sender: TObject;
127 var VersionNo: integer);
128 procedure JobCodeChangeTimerTimer(Sender: TObject);
129 procedure JobGradeChangeTimerTimer(Sender: TObject);
130 procedure JobGradeDBComboBoxCloseUp(Sender: TObject);
131 procedure NewDatabaseExecute(Sender: TObject);
132 procedure QuitExecute(Sender: TObject);
133 procedure RestoreDatabaseExecute(Sender: TObject);
134 procedure SaveDatabaseExecute(Sender: TObject);
135 procedure SelectDeptExecute(Sender: TObject);
136 procedure AddEmployeeExecute(Sender: TObject);
137 procedure BeforeDateChange(Sender: TObject);
138 procedure CancelChangesExecute(Sender: TObject);
139 procedure CountriesBeforeOpen(DataSet: TDataSet);
140 procedure DeleteEmployeeExecute(Sender: TObject);
141 procedure EditEmployeeExecute(Sender: TObject);
142 procedure EditEmployeeUpdate(Sender: TObject);
143 procedure EmployeesAfterInsert(DataSet: TDataSet);
144 procedure EmployeesAfterOpen(DataSet: TDataSet);
145 procedure EmployeesAfterScroll(DataSet: TDataSet);
146 procedure EmployeesBeforeClose(DataSet: TDataSet);
147 procedure EmployeesBeforeOpen(DataSet: TDataSet);
148 procedure EmployeesJOB_CODEChange(Sender: TField);
149 procedure EmployeesJOB_GRADEChange(Sender: TField);
150 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
151 procedure FormShow(Sender: TObject);
152 procedure EmployeesAfterDelete(DataSet: TDataSet);
153 procedure EmployeesAfterTransactionEnd(Sender: TObject);
154 procedure EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
155 var DataAction: TDataAction);
156 procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
157 DisplayText: Boolean);
158 procedure JobCodesBeforeOpen(DataSet: TDataSet);
159 procedure SaveChangesExecute(Sender: TObject);
160 procedure SaveChangesUpdate(Sender: TObject);
161 private
162 FCurrentDBVersion: integer;
163 { private declarations }
164 FDirty: boolean;
165 FNoAutoReopen: boolean;
166 procedure Reopen(Data: PtrInt);
167 function GetDBVersionNo: integer;
168 public
169 { public declarations }
170 property CurrentDBVersion: integer read FCurrentDBVersion;
171 end;
172
173 var
174 Form1: TForm1;
175
176 implementation
177
178 {$R *.lfm}
179
180 uses IB, Unit2;
181
182 const
183 sNoName = '<no name>';
184
185 function ExtractDBException(msg: string): string;
186 var Lines: TStringList;
187 begin
188 Lines := TStringList.Create;
189 try
190 Lines.Text := msg;
191 if pos('exception',Lines[0]) = 1 then
192 Result := Lines[2]
193 else
194 Result := msg
195 finally
196 Lines.Free
197 end;
198 end;
199
200 { TForm1 }
201
202 procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
203 DisplayText: Boolean);
204 begin
205 if DisplayText then
206 begin
207 if Sender.IsNUll then
208 aText := ''
209 else
210 aText := FormatFloat('$#,##0.00',Sender.AsFloat)
211 end
212 else
213 aText := Sender.AsString
214 end;
215
216 procedure TForm1.JobCodesBeforeOpen(DataSet: TDataSet);
217 begin
218 JobCodes.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
219 JobCodes.ParamByName('JOB_COUNTRY').AsString := EmployeesJOB_COUNTRY.AsString
220 end;
221
222 procedure TForm1.SaveChangesExecute(Sender: TObject);
223 begin
224 Employees.Transaction.Commit
225 end;
226
227 procedure TForm1.SaveChangesUpdate(Sender: TObject);
228 begin
229 (Sender as TAction).Enabled := FDirty
230 end;
231
232 procedure TForm1.Reopen(Data: PtrInt);
233 begin
234 with IBTransaction1 do
235 if not InTransaction then StartTransaction;
236 Countries.Active := true;
237 Employees.Active := true;
238 JobCodes.Active := true;
239 Depts.Active := true;
240 end;
241
242 function TForm1.GetDBVersionNo: integer;
243 begin
244 FCurrentDBVersion := 0;
245 Result := 0;
246 FNoAutoReopen := true;
247 try
248 with IBTransaction1 do
249 if not InTransaction then StartTransaction;
250 try
251 with CheckVersionTablePresent do
252 begin
253 ExecQuery;
254 try
255 if EOF then Exit;
256 finally
257 Close;
258 end;
259 end;
260
261 with GetDBVersionNoQuery do
262 begin
263 ExecQuery;
264 try
265 Result := FieldByName('VersionNo').AsInteger;
266 FCurrentDBVersion := Result;
267 finally
268 Close;
269 end;
270 end;
271 finally
272 IBTransaction1.Commit;
273 end;
274 finally
275 FNoAutoReopen := false
276 end;
277 end;
278
279
280 procedure TForm1.AddEmployeeExecute(Sender: TObject);
281 begin
282 Employees.Append
283 end;
284
285 procedure TForm1.SelectDeptExecute(Sender: TObject);
286 var Dept_No: string;
287 begin
288 if SelectDeptDlg.ShowModal(EmployeesDEPT_KEY_PATH.AsString,Dept_No) = mrOK then
289 begin
290 Employees.Edit;
291 EmployeesDEPT_NO.AsString := Dept_No;
292 try
293 Employees.Post;
294 except
295 Employees.Cancel;
296 raise;
297 end;
298 IBDynamicGrid1.ShowEditorPanel;
299 end;
300 end;
301
302 procedure TForm1.DBImage1DBImageRead(Sender: TObject; S: TStream;
303 var GraphExt: string);
304 begin
305 GraphExt := 'png';
306 end;
307
308 procedure TForm1.EmployeesValidatePost(Sender: TObject; var CancelPost: boolean
309 );
310 begin
311 {Cancel if no name entered}
312 CancelPost := (EmployeesLAST_NAME.AsString = sNoName) and (EmployeesFIRST_NAME.AsString = sNoName);
313 end;
314
315 procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
316 begin
317 with IBLocalDBSupport1 do
318 if CurrentDBVersionNo = RequiredVersionNo then
319 ReOpen(0);
320 end;
321
322 procedure TForm1.IBLocalDBSupport1GetDBVersionNo(Sender: TObject;
323 var VersionNo: integer);
324 begin
325 VersionNo := GetDBVersionNo;
326 end;
327
328 procedure TForm1.JobCodeChangeTimerTimer(Sender: TObject);
329 begin
330 Countries.Active := false;
331 Countries.Active := true;
332 JobCodeChangeTimer.Interval := 0;
333 end;
334
335 procedure TForm1.JobGradeChangeTimerTimer(Sender: TObject);
336 begin
337 Countries.Active := false;
338 JobCodes.Active := false;
339 Countries.Active := true;
340 JobCodes.Active := true;
341 JobGradeChangeTimer.Interval := 0;
342 end;
343
344 procedure TForm1.JobGradeDBComboBoxCloseUp(Sender: TObject);
345 begin
346 JobGradeDBComboBox.EditingDone; //See http://bugs.freepascal.org/view.php?id=27186
347 end;
348
349 procedure TForm1.NewDatabaseExecute(Sender: TObject);
350 begin
351 FNoAutoReopen := true;
352 try
353 {Ensure Transaction End}
354 if IBTransaction1.InTransaction then
355 IBTransaction1.Rollback;
356 finally
357 FNoAutoReopen := false;
358 end;
359 IBLocalDBSupport1.NewDatabase;
360 end;
361
362 procedure TForm1.QuitExecute(Sender: TObject);
363 begin
364 Close;
365 end;
366
367 procedure TForm1.RestoreDatabaseExecute(Sender: TObject);
368 begin
369 FNoAutoReopen := true;
370 try
371 {Ensure all changes saved}
372 if IBTransaction1.InTransaction then
373 IBTransaction1.Commit;
374 finally
375 FNoAutoReopen := false;
376 end;
377 IBLocalDBSupport1.RestoreDatabase;
378 end;
379
380 procedure TForm1.SaveDatabaseExecute(Sender: TObject);
381 begin
382 FNoAutoReopen := true;
383 try
384 {Ensure all changes saved}
385 if IBTransaction1.InTransaction then
386 IBTransaction1.Commit;
387 finally
388 FNoAutoReopen := false;
389 end;
390 IBLocalDBSupport1.SaveDatabase;
391 {Start new Transaction and open dataset}
392 ReOpen(0);
393 end;
394
395 procedure TForm1.BeforeDateChange(Sender: TObject);
396 begin
397 Employees.Active := false;
398 Employees.Active := true
399 end;
400
401 procedure TForm1.CancelChangesExecute(Sender: TObject);
402 begin
403 Employees.Transaction.Rollback
404 end;
405
406 procedure TForm1.CountriesBeforeOpen(DataSet: TDataSet);
407 begin
408 Countries.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
409 Countries.ParamByName('JOB_CODE').AsString := EmployeesJOB_CODE.AsString
410 end;
411
412 procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
413 begin
414 if MessageDlg(
415 Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
416 mtConfirmation,[mbYes,mbNo],0) = mrYes then
417 Employees.Delete
418 end;
419
420 procedure TForm1.EditEmployeeExecute(Sender: TObject);
421 begin
422 IBDynamicGrid1.ShowEditorPanel;
423 end;
424
425 procedure TForm1.EditEmployeeUpdate(Sender: TObject);
426 begin
427 (Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
428 end;
429
430 procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
431 begin
432 EmployeesJOB_COUNTRY.AsString := 'USA';
433 EmployeesJOB_CODE.AsString := 'SRep';
434 EmployeesJOB_GRADE.AsInteger := 4;
435 EmployeesSALARY.AsCurrency := 20000;
436 EmployeesFIRST_NAME.AsString := sNoName;
437 EmployeesLAST_NAME.AsString := sNoName;
438 EmployeesHIRE_DATE.AsDateTime := now;
439 EmployeesDEPT_NO.AsString := '000';
440 FDirty := true;
441 end;
442
443 procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
444 begin
445 TotalsQuery.Active := true;
446 IBDynamicGrid1.SetFocus;
447 end;
448
449 procedure TForm1.EmployeesAfterScroll(DataSet: TDataSet);
450 begin
451 JobGradeChangeTimer.Interval := 200;
452 end;
453
454 procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
455 begin
456 TotalsQuery.Active := false
457 end;
458
459 procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
460 begin
461 if BeforeDate.Date > 0 then
462 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE < :BeforeDate');
463 if AfterDate.Date > 0 then
464 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE > :AfterDate');
465
466 case SalaryRange.ItemIndex of
467 1:
468 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary < 40000');
469 2:
470 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 40000 and Salary < 100000');
471 3:
472 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 100000');
473 end;
474
475
476
477 {Parameter value must be set after all SQL changes have been made}
478 if BeforeDate.Date > 0 then
479 (DataSet as TIBParserDataSet).ParamByName('BeforeDate').AsDateTime := BeforeDate.Date;
480 if AfterDate.Date > 0 then
481 (DataSet as TIBParserDataSet).ParamByName('AfterDate').AsDateTime := AfterDate.Date;
482
483 end;
484
485 procedure TForm1.EmployeesJOB_CODEChange(Sender: TField);
486 begin
487 JobCodeChangeTimer.Interval := 200;
488 end;
489
490 procedure TForm1.EmployeesJOB_GRADEChange(Sender: TField);
491 begin
492 JobGradeChangeTimer.Interval := 200;
493 end;
494
495 procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
496 begin
497 FNoAutoReopen := true;
498 if IBTransaction1.InTransaction then
499 IBTransaction1.Commit;
500 end;
501
502 procedure TForm1.FormShow(Sender: TObject);
503 begin
504 try
505 IBDatabase1.Connected := true;
506 except On E:Exception do
507 begin
508 MessageDlg(E.Message,mtError,[mbOK],0);
509 Close;
510 Exit
511 end;
512 end;
513
514 {If upgrade failed or downgrade not pending then exit}
515 with IBLocalDBSupport1 do
516 if (CurrentDBVersionNo < RequiredVersionNo) or
517 ((CurrentDBVersionNo > RequiredVersionNo) and not DowngradePending) then
518 Close;
519 end;
520
521 procedure TForm1.EmployeesAfterDelete(DataSet: TDataSet);
522 begin
523 FDirty := true
524 end;
525
526 procedure TForm1.EmployeesAfterTransactionEnd(Sender: TObject);
527 begin
528 FDirty := false;
529 if not FNoAutoReopen then
530 Application.QueueAsyncCall(@Reopen,0)
531 end;
532
533 procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
534 var DataAction: TDataAction);
535 begin
536 if E is EIBError then
537 begin
538 MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
539 DataSet.Cancel;
540 DataAction := daAbort
541 end;
542 end;
543
544 end.
545