ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/employee/unit1.pas
(Generate patch)

Comparing ibx/trunk/examples/employee/unit1.pas (file contents):
Revision 29 by tony, Sat May 9 11:37:49 2015 UTC vs.
Revision 33 by tony, Sat Jul 18 12:30:52 2015 UTC

# Line 1 | Line 1
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 <
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 >

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines