ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/local-employeedb/unit1.pas
Revision: 143
Committed: Fri Feb 23 12:11:21 2018 UTC (6 years, 1 month ago) by tony
Content type: text/x-pascal
File size: 15311 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;
207
208 const
209 sNoName = '<no name>';
210
211 function ExtractDBException(msg: string): string;
212 var Lines: TStringList;
213 begin
214 Lines := TStringList.Create;
215 try
216 Lines.Text := msg;
217 if pos('exception',Lines[0]) = 1 then
218 Result := Lines[2]
219 else
220 Result := msg
221 finally
222 Lines.Free
223 end;
224 end;
225
226 { TForm1 }
227
228 procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
229 DisplayText: Boolean);
230 begin
231 if DisplayText then
232 begin
233 if Sender.IsNUll then
234 aText := ''
235 else
236 aText := FormatFloat('$#,##0.00',Sender.AsFloat)
237 end
238 else
239 aText := Sender.AsString
240 end;
241
242 procedure TForm1.JobCodesBeforeOpen(DataSet: TDataSet);
243 begin
244 JobCodes.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
245 JobCodes.ParamByName('JOB_COUNTRY').AsString := EmployeesJOB_COUNTRY.AsString
246 end;
247
248 procedure TForm1.SaveChangesExecute(Sender: TObject);
249 begin
250 Employees.Transaction.Commit
251 end;
252
253 procedure TForm1.SaveChangesUpdate(Sender: TObject);
254 begin
255 (Sender as TAction).Enabled := FDirty
256 end;
257
258 procedure TForm1.Reopen(Data: PtrInt);
259 begin
260 with IBTransaction1 do
261 if not InTransaction then StartTransaction;
262 Countries.Active := true;
263 Employees.Active := true;
264 JobCodes.Active := true;
265 Depts.Active := true;
266 end;
267
268 function TForm1.GetDBVersionNo: integer;
269 begin
270 FCurrentDBVersion := 0;
271 Result := 0;
272 FNoAutoReopen := true;
273 try
274 with IBTransaction1 do
275 if not InTransaction then StartTransaction;
276 try
277 with CheckVersionTablePresent do
278 begin
279 ExecQuery;
280 try
281 if EOF then Exit;
282 finally
283 Close;
284 end;
285 end;
286
287 with GetDBVersionNoQuery do
288 begin
289 ExecQuery;
290 try
291 Result := FieldByName('VersionNo').AsInteger;
292 FCurrentDBVersion := Result;
293 finally
294 Close;
295 end;
296 end;
297 finally
298 IBTransaction1.Commit;
299 end;
300 finally
301 FNoAutoReopen := false
302 end;
303 end;
304
305
306 procedure TForm1.AddEmployeeExecute(Sender: TObject);
307 begin
308 Employees.Append
309 end;
310
311 procedure TForm1.SelectDeptExecute(Sender: TObject);
312 var Dept_No: string;
313 begin
314 if SelectDeptDlg.ShowModal(EmployeesDEPT_KEY_PATH.AsString,Dept_No) = mrOK then
315 begin
316 Employees.Edit;
317 EmployeesDEPT_NO.AsString := Dept_No;
318 try
319 Employees.Post;
320 except
321 Employees.Cancel;
322 raise;
323 end;
324 IBDynamicGrid1.ShowEditorPanel;
325 end;
326 end;
327
328 procedure TForm1.DBImage1DBImageRead(Sender: TObject; S: TStream;
329 var GraphExt: string);
330 begin
331 GraphExt := 'png';
332 end;
333
334 procedure TForm1.EmployeesValidatePost(Sender: TObject; var CancelPost: boolean
335 );
336 begin
337 {Cancel if no name entered}
338 CancelPost := (EmployeesLAST_NAME.AsString = sNoName) and (EmployeesFIRST_NAME.AsString = sNoName);
339 end;
340
341 procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
342 begin
343 with IBLocalDBSupport1 do
344 if CurrentDBVersionNo = RequiredVersionNo then
345 ReOpen(0);
346 end;
347
348 procedure TForm1.IBLocalDBSupport1GetDBVersionNo(Sender: TObject;
349 var VersionNo: integer);
350 begin
351 VersionNo := GetDBVersionNo;
352 end;
353
354 procedure TForm1.JobCodeChangeTimerTimer(Sender: TObject);
355 begin
356 Countries.Active := false;
357 Countries.Active := true;
358 JobCodeChangeTimer.Interval := 0;
359 end;
360
361 procedure TForm1.JobGradeChangeTimerTimer(Sender: TObject);
362 begin
363 Countries.Active := false;
364 JobCodes.Active := false;
365 Countries.Active := true;
366 JobCodes.Active := true;
367 JobGradeChangeTimer.Interval := 0;
368 end;
369
370 procedure TForm1.JobGradeDBComboBoxCloseUp(Sender: TObject);
371 begin
372 JobGradeDBComboBox.EditingDone; //See http://bugs.freepascal.org/view.php?id=27186
373 end;
374
375 procedure TForm1.NewDatabaseExecute(Sender: TObject);
376 begin
377 FNoAutoReopen := true;
378 try
379 {Ensure Transaction End}
380 if IBTransaction1.InTransaction then
381 IBTransaction1.Rollback;
382 finally
383 FNoAutoReopen := false;
384 end;
385 IBLocalDBSupport1.NewDatabase;
386 end;
387
388 procedure TForm1.QuitExecute(Sender: TObject);
389 begin
390 Close;
391 end;
392
393 procedure TForm1.RestoreDatabaseExecute(Sender: TObject);
394 begin
395 FNoAutoReopen := true;
396 try
397 {Ensure all changes saved}
398 if IBTransaction1.InTransaction then
399 IBTransaction1.Commit;
400 finally
401 FNoAutoReopen := false;
402 end;
403 IBLocalDBSupport1.RestoreDatabase;
404 end;
405
406 procedure TForm1.SaveDatabaseExecute(Sender: TObject);
407 begin
408 FNoAutoReopen := true;
409 try
410 {Ensure all changes saved}
411 if IBTransaction1.InTransaction then
412 IBTransaction1.Commit;
413 finally
414 FNoAutoReopen := false;
415 end;
416 IBLocalDBSupport1.SaveDatabase;
417 {Start new Transaction and open dataset}
418 ReOpen(0);
419 end;
420
421 procedure TForm1.BeforeDateChange(Sender: TObject);
422 begin
423 Employees.Active := false;
424 Employees.Active := true
425 end;
426
427 procedure TForm1.CancelChangesExecute(Sender: TObject);
428 begin
429 Employees.Transaction.Rollback
430 end;
431
432 procedure TForm1.CountriesBeforeOpen(DataSet: TDataSet);
433 begin
434 Countries.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
435 Countries.ParamByName('JOB_CODE').AsString := EmployeesJOB_CODE.AsString
436 end;
437
438 procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
439 begin
440 if MessageDlg(
441 Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
442 mtConfirmation,[mbYes,mbNo],0) = mrYes then
443 Employees.Delete
444 end;
445
446 procedure TForm1.EditEmployeeExecute(Sender: TObject);
447 begin
448 IBDynamicGrid1.ShowEditorPanel;
449 end;
450
451 procedure TForm1.EditEmployeeUpdate(Sender: TObject);
452 begin
453 (Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
454 end;
455
456 procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
457 begin
458 EmployeesJOB_COUNTRY.AsString := 'USA';
459 EmployeesJOB_CODE.AsString := 'SRep';
460 EmployeesJOB_GRADE.AsInteger := 4;
461 EmployeesSALARY.AsCurrency := 20000;
462 EmployeesFIRST_NAME.AsString := sNoName;
463 EmployeesLAST_NAME.AsString := sNoName;
464 EmployeesHIRE_DATE.AsDateTime := now;
465 EmployeesDEPT_NO.AsString := '000';
466 FDirty := true;
467 end;
468
469 procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
470 begin
471 TotalsQuery.Active := true;
472 IBDynamicGrid1.SetFocus;
473 end;
474
475 procedure TForm1.EmployeesAfterScroll(DataSet: TDataSet);
476 begin
477 JobGradeChangeTimer.Interval := 200;
478 end;
479
480 procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
481 begin
482 TotalsQuery.Active := false
483 end;
484
485 procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
486 begin
487 if BeforeDate.Date > 0 then
488 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE < :BeforeDate');
489 if AfterDate.Date > 0 then
490 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE > :AfterDate');
491
492 case SalaryRange.ItemIndex of
493 1:
494 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary < 40000');
495 2:
496 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 40000 and Salary < 100000');
497 3:
498 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 100000');
499 end;
500
501
502
503 {Parameter value must be set after all SQL changes have been made}
504 if BeforeDate.Date > 0 then
505 (DataSet as TIBParserDataSet).ParamByName('BeforeDate').AsDateTime := BeforeDate.Date;
506 if AfterDate.Date > 0 then
507 (DataSet as TIBParserDataSet).ParamByName('AfterDate').AsDateTime := AfterDate.Date;
508
509 end;
510
511 procedure TForm1.EmployeesJOB_CODEChange(Sender: TField);
512 begin
513 JobCodeChangeTimer.Interval := 200;
514 end;
515
516 procedure TForm1.EmployeesJOB_GRADEChange(Sender: TField);
517 begin
518 JobGradeChangeTimer.Interval := 200;
519 end;
520
521 procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
522 begin
523 FNoAutoReopen := true;
524 if IBTransaction1.InTransaction then
525 IBTransaction1.Commit;
526 end;
527
528 procedure TForm1.FormShow(Sender: TObject);
529 begin
530 try
531 IBDatabase1.Connected := true;
532 except On E:Exception do
533 begin
534 MessageDlg(E.Message,mtError,[mbOK],0);
535 Close;
536 Exit
537 end;
538 end;
539
540 {If upgrade failed or downgrade not pending then exit}
541 with IBLocalDBSupport1 do
542 if (CurrentDBVersionNo < RequiredVersionNo) or
543 ((CurrentDBVersionNo > RequiredVersionNo) and not DowngradePending) then
544 Close;
545 end;
546
547 procedure TForm1.EmployeesAfterDelete(DataSet: TDataSet);
548 begin
549 FDirty := true
550 end;
551
552 procedure TForm1.EmployeesAfterTransactionEnd(Sender: TObject);
553 begin
554 FDirty := false;
555 if not FNoAutoReopen then
556 Application.QueueAsyncCall(@Reopen,0)
557 end;
558
559 procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
560 var DataAction: TDataAction);
561 begin
562 if E is EIBError then
563 begin
564 MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
565 DataSet.Cancel;
566 DataAction := daAbort
567 end;
568 end;
569
570 end.
571