ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/employee/unit1.pas
Revision: 107
Committed: Thu Jan 18 14:37:40 2018 UTC (6 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 11123 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, 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 EmployeesTEst: TStringField;
22 IBLookupComboEditBox1: TIBLookupComboEditBox;
23 IBLookupComboEditBox2: TIBLookupComboEditBox;
24 IBQuery1DEPT_NO: TIBStringField;
25 IBQuery1EMP_NO: TSmallintField;
26 IBQuery1FIRST_NAME: TIBStringField;
27 IBQuery1FULL_NAME: TIBStringField;
28 IBQuery1HIRE_DATE: TDateTimeField;
29 IBQuery1JOB_CODE: TIBStringField;
30 IBQuery1JOB_COUNTRY: TIBStringField;
31 IBQuery1JOB_GRADE: TSmallintField;
32 IBQuery1LAST_NAME: TIBStringField;
33 IBQuery1PHONE_EXT: TIBStringField;
34 IBQuery1SALARY: TIBBCDField;
35 SelectDept: TAction;
36 Button4: TButton;
37 Button5: TButton;
38 CancelChanges: TAction;
39 SalaryRange: TComboBox;
40 CountrySource: TDataSource;
41 BeforeDate: TDateEdit;
42 AfterDate: TDateEdit;
43 DeptsSource: TDataSource;
44 Depts: TIBQuery;
45 JobCodeSource: TDataSource;
46 DBEdit1: TDBEdit;
47 DBEdit2: TDBEdit;
48 DBEdit3: TDBEdit;
49 DBEdit4: TDBEdit;
50 DBEdit5: TDBEdit;
51 DBText1: TDBText;
52 Employees: TIBDataSet;
53 EmployeesDEPT_NO: TIBStringField;
54 EmployeesEMP_NO: TSmallintField;
55 EmployeesFIRST_NAME: TIBStringField;
56 EmployeesFULL_NAME: TIBStringField;
57 EmployeesHIRE_DATE: TDateTimeField;
58 EmployeesJOB_CODE: TIBStringField;
59 EmployeesJOB_COUNTRY: TIBStringField;
60 EmployeesJOB_GRADE: TSmallintField;
61 EmployeesLAST_NAME: TIBStringField;
62 EmployeesPHONE_EXT: TIBStringField;
63 EmployeesSALARY: TIBBCDField;
64 IBDateEdit1: TDBDateEdit;
65 IBDynamicGrid1: TIBDynamicGrid;
66 Countries: TIBQuery;
67 JobCodes: TIBQuery;
68 JobGradeDBComboBox: TDBComboBox;
69 Label10: TLabel;
70 Label11: TLabel;
71 Label12: TLabel;
72 Label13: TLabel;
73 Label3: TLabel;
74 Label4: TLabel;
75 Label5: TLabel;
76 Label6: TLabel;
77 Label7: TLabel;
78 Label8: TLabel;
79 Label9: TLabel;
80 Panel1: TPanel;
81 Panel2: TPanel;
82 EmployeeEditorPanel: TPanel;
83 SpeedButton1: TSpeedButton;
84 JobGradeChangeTimer: TTimer;
85 JobCodeChangeTimer: TTimer;
86 TotalsQueryTOTALSALARIES: TIBBCDField;
87 TotalsSource: TDataSource;
88 TotalsQuery: TIBQuery;
89 Label1: TLabel;
90 Label2: TLabel;
91 SaveChanges: TAction;
92 DeleteEmployee: TAction;
93 EditEmployee: TAction;
94 AddEmployee: TAction;
95 ActionList1: TActionList;
96 Button1: TButton;
97 Button2: TButton;
98 Button3: TButton;
99 EmployeeSource: TDataSource;
100 IBDatabase1: TIBDatabase;
101 IBTransaction1: TIBTransaction;
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.EmployeesValidatePost(Sender: TObject; var CancelPost: boolean
233 );
234 begin
235 {Cancel if no name entered}
236 CancelPost := (EmployeesLAST_NAME.AsString = sNoName) and (EmployeesFIRST_NAME.AsString = sNoName);
237 end;
238
239 procedure TForm1.JobCodeChangeTimerTimer(Sender: TObject);
240 begin
241 Countries.Active := false;
242 Countries.Active := true;
243 JobCodeChangeTimer.Interval := 0;
244 end;
245
246 procedure TForm1.JobGradeChangeTimerTimer(Sender: TObject);
247 begin
248 Countries.Active := false;
249 JobCodes.Active := false;
250 Countries.Active := true;
251 JobCodes.Active := true;
252 JobGradeChangeTimer.Interval := 0;
253 end;
254
255 procedure TForm1.JobGradeDBComboBoxCloseUp(Sender: TObject);
256 begin
257 JobGradeDBComboBox.EditingDone; //See http://bugs.freepascal.org/view.php?id=27186
258 end;
259
260 procedure TForm1.BeforeDateChange(Sender: TObject);
261 begin
262 Employees.Active := false;
263 Employees.Active := true
264 end;
265
266 procedure TForm1.CancelChangesExecute(Sender: TObject);
267 begin
268 Employees.Transaction.Rollback
269 end;
270
271 procedure TForm1.CountriesBeforeOpen(DataSet: TDataSet);
272 begin
273 Countries.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
274 Countries.ParamByName('JOB_CODE').AsString := EmployeesJOB_CODE.AsString
275 end;
276
277 procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
278 begin
279 if MessageDlg(
280 Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
281 mtConfirmation,[mbYes,mbNo],0) = mrYes then
282 Employees.Delete
283 end;
284
285 procedure TForm1.EditEmployeeExecute(Sender: TObject);
286 begin
287 IBDynamicGrid1.ShowEditorPanel;
288 end;
289
290 procedure TForm1.EditEmployeeUpdate(Sender: TObject);
291 begin
292 (Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
293 end;
294
295 procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
296 begin
297 EmployeesJOB_COUNTRY.AsString := 'USA';
298 EmployeesJOB_CODE.AsString := 'SRep';
299 EmployeesJOB_GRADE.AsInteger := 4;
300 EmployeesSALARY.AsCurrency := 20000;
301 EmployeesFIRST_NAME.AsString := sNoName;
302 EmployeesLAST_NAME.AsString := sNoName;
303 EmployeesHIRE_DATE.AsDateTime := now;
304 EmployeesDEPT_NO.AsString := '000';
305 FDirty := true;
306 end;
307
308 procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
309 begin
310 TotalsQuery.Active := true;
311 IBDynamicGrid1.SetFocus;
312 end;
313
314 procedure TForm1.EmployeesAfterScroll(DataSet: TDataSet);
315 begin
316 JobGradeChangeTimer.Interval := 200;
317 end;
318
319 procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
320 begin
321 TotalsQuery.Active := false
322 end;
323
324 procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
325 begin
326 if BeforeDate.Date > 0 then
327 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE < :BeforeDate');
328 if AfterDate.Date > 0 then
329 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE > :AfterDate');
330
331 case SalaryRange.ItemIndex of
332 1:
333 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary < 40000');
334 2:
335 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 40000 and Salary < 100000');
336 3:
337 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 100000');
338 end;
339
340
341
342 {Parameter value must be set after all SQL changes have been made}
343 if BeforeDate.Date > 0 then
344 (DataSet as TIBParserDataSet).ParamByName('BeforeDate').AsDateTime := BeforeDate.Date;
345 if AfterDate.Date > 0 then
346 (DataSet as TIBParserDataSet).ParamByName('AfterDate').AsDateTime := AfterDate.Date;
347
348 end;
349
350 procedure TForm1.EmployeesJOB_CODEChange(Sender: TField);
351 begin
352 JobCodeChangeTimer.Interval := 200;
353 end;
354
355 procedure TForm1.EmployeesJOB_GRADEChange(Sender: TField);
356 begin
357 JobGradeChangeTimer.Interval := 200;
358 end;
359
360 procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
361 begin
362 FClosing := true;
363 if IBTransaction1.InTransaction then
364 IBTransaction1.Commit;
365 end;
366
367 procedure TForm1.FormShow(Sender: TObject);
368 begin
369 repeat
370 try
371 IBDatabase1.Connected := true;
372 except
373 on E:EIBClientError do
374 begin
375 Close;
376 Exit
377 end;
378 On E:Exception do
379 MessageDlg(E.Message,mtError,[mbOK],0);
380 end;
381 until IBDatabase1.Connected;
382 Reopen(0);
383 end;
384
385 procedure TForm1.EmployeesAfterDelete(DataSet: TDataSet);
386 begin
387 FDirty := true
388 end;
389
390 procedure TForm1.EmployeesAfterTransactionEnd(Sender: TObject);
391 begin
392 FDirty := false;
393 if not FClosing then
394 Application.QueueAsyncCall(@Reopen,0)
395 end;
396
397 procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
398 var DataAction: TDataAction);
399 begin
400 if E is EIBError then
401 begin
402 MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
403 DataSet.Cancel;
404 DataAction := daAbort
405 end;
406 end;
407
408 end.
409