ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/local-employeedb/unit1.pas
Revision: 209
Committed: Wed Mar 14 12:48:51 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
File size: 15196 byte(s)
Log Message:
Fixes Merged

File Contents

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