ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/employee/unit1.pas
Revision: 27
Committed: Tue Apr 14 13:10:23 2015 UTC (9 years ago) by tony
Content type: text/x-pascal
File size: 11234 byte(s)
Log Message:
Committing updates for Release R1-2-3

File Contents

# User Rev Content
1 tony 17 unit Unit1;
2    
3     {$mode objfpc}{$H+}
4    
5     interface
6    
7     uses
8     Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, DBGrids,
9 tony 21 StdCtrls, ActnList, EditBtn, DbCtrls, ExtCtrls, Buttons, IBDatabase, IBQuery,
10     IBCustomDataSet, IBUpdateSQL, IBDynamicGrid, IBLookupComboEditBox,
11     db, DBExtCtrls;
12 tony 17
13     type
14    
15     { TForm1 }
16    
17     TForm1 = class(TForm)
18 tony 21 DBEdit6: TDBEdit;
19     EmployeesDEPT_KEY_PATH: TIBStringField;
20     EmployeesDEPT_PATH: TIBStringField;
21     IBLookupComboEditBox1: TIBLookupComboEditBox;
22     IBLookupComboEditBox2: TIBLookupComboEditBox;
23 tony 27 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 tony 21 SelectDept: TAction;
35     Button4: TButton;
36     Button5: TButton;
37 tony 17 CancelChanges: TAction;
38 tony 21 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     TotalsQueryTOTALSALARIES: TIBBCDField;
84     TotalsSource: TDataSource;
85     TotalsQuery: TIBQuery;
86     Label1: TLabel;
87     Label2: TLabel;
88 tony 17 SaveChanges: TAction;
89     DeleteEmployee: TAction;
90     EditEmployee: TAction;
91     AddEmployee: TAction;
92     ActionList1: TActionList;
93     Button1: TButton;
94     Button2: TButton;
95     Button3: TButton;
96 tony 21 EmployeeSource: TDataSource;
97 tony 17 IBDatabase1: TIBDatabase;
98     IBTransaction1: TIBTransaction;
99 tony 21 procedure EmployeesAfterPost(DataSet: TDataSet);
100 tony 27 procedure EmployeesValidatePost(Sender: TObject; var CancelPost: boolean);
101 tony 21 procedure JobGradeDBComboBoxCloseUp(Sender: TObject);
102     procedure SelectDeptExecute(Sender: TObject);
103 tony 17 procedure AddEmployeeExecute(Sender: TObject);
104 tony 21 procedure BeforeDateChange(Sender: TObject);
105 tony 17 procedure CancelChangesExecute(Sender: TObject);
106 tony 21 procedure CountriesBeforeOpen(DataSet: TDataSet);
107 tony 17 procedure DeleteEmployeeExecute(Sender: TObject);
108     procedure EditEmployeeExecute(Sender: TObject);
109     procedure EditEmployeeUpdate(Sender: TObject);
110 tony 21 procedure EmployeesAfterInsert(DataSet: TDataSet);
111     procedure EmployeesAfterOpen(DataSet: TDataSet);
112     procedure EmployeesAfterScroll(DataSet: TDataSet);
113     procedure EmployeesBeforeClose(DataSet: TDataSet);
114     procedure EmployeesBeforeOpen(DataSet: TDataSet);
115     procedure EmployeesJOB_CODEChange(Sender: TField);
116     procedure EmployeesJOB_GRADEChange(Sender: TField);
117 tony 17 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
118     procedure FormShow(Sender: TObject);
119 tony 21 procedure EmployeesAfterDelete(DataSet: TDataSet);
120     procedure EmployeesAfterTransactionEnd(Sender: TObject);
121     procedure EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
122 tony 17 var DataAction: TDataAction);
123 tony 21 procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
124 tony 17 DisplayText: Boolean);
125 tony 21 procedure JobCodesBeforeOpen(DataSet: TDataSet);
126 tony 17 procedure SaveChangesExecute(Sender: TObject);
127     procedure SaveChangesUpdate(Sender: TObject);
128     private
129     { private declarations }
130     FDirty: boolean;
131     FClosing: boolean;
132     procedure Reopen(Data: PtrInt);
133     public
134     { public declarations }
135     end;
136    
137     var
138     Form1: TForm1;
139    
140     implementation
141    
142     {$R *.lfm}
143    
144 tony 21 uses IB, Unit2;
145 tony 17
146 tony 27 const
147     sNoName = '<no name>';
148    
149 tony 17 function ExtractDBException(msg: string): string;
150     var Lines: TStringList;
151     begin
152     Lines := TStringList.Create;
153     try
154     Lines.Text := msg;
155     if pos('exception',Lines[0]) = 1 then
156     Result := Lines[2]
157     else
158     Result := msg
159     finally
160     Lines.Free
161     end;
162     end;
163    
164     { TForm1 }
165    
166 tony 21 procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
167 tony 17 DisplayText: Boolean);
168     begin
169     if DisplayText then
170     begin
171     if Sender.IsNUll then
172     aText := ''
173     else
174     aText := FormatFloat('$#,##0.00',Sender.AsFloat)
175     end
176     else
177     aText := Sender.AsString
178     end;
179    
180 tony 21 procedure TForm1.JobCodesBeforeOpen(DataSet: TDataSet);
181     begin
182     JobCodes.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
183     JobCodes.ParamByName('JOB_COUNTRY').AsString := EmployeesJOB_COUNTRY.AsString
184     end;
185    
186 tony 17 procedure TForm1.SaveChangesExecute(Sender: TObject);
187     begin
188 tony 21 Employees.Transaction.Commit
189 tony 17 end;
190    
191     procedure TForm1.SaveChangesUpdate(Sender: TObject);
192     begin
193     (Sender as TAction).Enabled := FDirty
194     end;
195    
196     procedure TForm1.Reopen(Data: PtrInt);
197     begin
198     with IBTransaction1 do
199     if not InTransaction then StartTransaction;
200 tony 21 Countries.Active := true;
201     Employees.Active := true;
202     JobCodes.Active := true;
203     Depts.Active := true;
204 tony 17 end;
205    
206     procedure TForm1.AddEmployeeExecute(Sender: TObject);
207     begin
208 tony 21 Employees.Append
209     end;
210    
211     procedure TForm1.SelectDeptExecute(Sender: TObject);
212     var Dept_No: string;
213     begin
214     if SelectDeptDlg.ShowModal(EmployeesDEPT_KEY_PATH.AsString,Dept_No) = mrOK then
215 tony 17 begin
216 tony 21 Employees.Edit;
217     EmployeesDEPT_NO.AsString := Dept_No;
218     try
219     Employees.Post;
220     except
221     Employees.Cancel;
222     raise;
223     end;
224     IBDynamicGrid1.ShowEditorPanel;
225 tony 17 end;
226     end;
227    
228 tony 21 procedure TForm1.EmployeesAfterPost(DataSet: TDataSet);
229     begin
230     Employees.Refresh
231     end;
232    
233 tony 27 procedure TForm1.EmployeesValidatePost(Sender: TObject; var CancelPost: boolean
234     );
235     begin
236     {Cancel if no name entered}
237     CancelPost := (EmployeesLAST_NAME.AsString = sNoName) and (EmployeesFIRST_NAME.AsString = sNoName);
238     end;
239    
240 tony 21 procedure TForm1.JobGradeDBComboBoxCloseUp(Sender: TObject);
241     begin
242     JobGradeDBComboBox.EditingDone; //See http://bugs.freepascal.org/view.php?id=27186
243     end;
244    
245     procedure TForm1.BeforeDateChange(Sender: TObject);
246     begin
247     Employees.Active := false;
248     Employees.Active := true
249     end;
250    
251 tony 17 procedure TForm1.CancelChangesExecute(Sender: TObject);
252     begin
253 tony 21 Employees.Transaction.Rollback
254 tony 17 end;
255    
256 tony 21 procedure TForm1.CountriesBeforeOpen(DataSet: TDataSet);
257 tony 17 begin
258 tony 21 Countries.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
259     Countries.ParamByName('JOB_CODE').AsString := EmployeesJOB_CODE.AsString
260 tony 17 end;
261    
262     procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
263     begin
264     if MessageDlg(
265 tony 21 Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
266 tony 17 mtConfirmation,[mbYes,mbNo],0) = mrYes then
267 tony 21 Employees.Delete
268 tony 17 end;
269    
270     procedure TForm1.EditEmployeeExecute(Sender: TObject);
271     begin
272 tony 21 IBDynamicGrid1.ShowEditorPanel;
273 tony 17 end;
274    
275     procedure TForm1.EditEmployeeUpdate(Sender: TObject);
276     begin
277 tony 21 (Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
278 tony 17 end;
279    
280 tony 21 procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
281 tony 17 begin
282 tony 21 EmployeesJOB_COUNTRY.AsString := 'USA';
283     EmployeesJOB_CODE.AsString := 'SRep';
284     EmployeesJOB_GRADE.AsInteger := 4;
285     EmployeesSALARY.AsCurrency := 20000;
286 tony 27 EmployeesFIRST_NAME.AsString := sNoName;
287     EmployeesLAST_NAME.AsString := sNoName;
288 tony 21 EmployeesHIRE_DATE.AsDateTime := now;
289     EmployeesDEPT_NO.AsString := '000';
290     FDirty := true;
291 tony 17 end;
292    
293 tony 21 procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
294 tony 17 begin
295 tony 27 TotalsQuery.Active := true;
296     IBDynamicGrid1.SetFocus;
297 tony 17 end;
298    
299 tony 21 procedure TForm1.EmployeesAfterScroll(DataSet: TDataSet);
300 tony 17 begin
301 tony 21 Countries.Active := false;
302     JobCodes.Active := false;
303     Countries.Active := true;
304     JobCodes.Active := true;
305 tony 17 end;
306    
307 tony 21 procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
308 tony 17 begin
309 tony 21 TotalsQuery.Active := false
310 tony 17 end;
311    
312 tony 21 procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
313 tony 17 begin
314 tony 21 if BeforeDate.Date > 0 then
315     (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE < :BeforeDate');
316     if AfterDate.Date > 0 then
317     (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE > :AfterDate');
318    
319     case SalaryRange.ItemIndex of
320     1:
321     (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary < 40000');
322     2:
323     (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 40000 and Salary < 100000');
324     3:
325     (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 100000');
326     end;
327    
328    
329    
330     {Parameter value must be set after all SQL changes have been made}
331     if BeforeDate.Date > 0 then
332     (DataSet as TIBParserDataSet).ParamByName('BeforeDate').AsDateTime := BeforeDate.Date;
333     if AfterDate.Date > 0 then
334     (DataSet as TIBParserDataSet).ParamByName('AfterDate').AsDateTime := AfterDate.Date;
335    
336 tony 17 end;
337    
338 tony 21 procedure TForm1.EmployeesJOB_CODEChange(Sender: TField);
339 tony 17 begin
340 tony 21 Countries.Active := false;
341     Countries.Active := true;
342 tony 17 end;
343    
344 tony 21 procedure TForm1.EmployeesJOB_GRADEChange(Sender: TField);
345 tony 17 begin
346 tony 21 Countries.Active := false;
347     JobCodes.Active := false;
348     Countries.Active := true;
349     JobCodes.Active := true;
350     end;
351    
352     procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
353     begin
354     FClosing := true;
355     if IBTransaction1.InTransaction then
356     IBTransaction1.Commit;
357     end;
358    
359     procedure TForm1.FormShow(Sender: TObject);
360     begin
361     repeat
362     try
363     IBDatabase1.Connected := true;
364     except
365     on E:EIBClientError do
366     begin
367     Close;
368     Exit
369     end;
370     On E:Exception do
371     MessageDlg(E.Message,mtError,[mbOK],0);
372     end;
373     until IBDatabase1.Connected;
374     Reopen(0);
375     end;
376    
377     procedure TForm1.EmployeesAfterDelete(DataSet: TDataSet);
378     begin
379     FDirty := true
380     end;
381    
382     procedure TForm1.EmployeesAfterTransactionEnd(Sender: TObject);
383     begin
384 tony 17 FDirty := false;
385     if not FClosing then
386     Application.QueueAsyncCall(@Reopen,0)
387     end;
388    
389 tony 21 procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
390 tony 17 var DataAction: TDataAction);
391     begin
392     if E is EIBError then
393     begin
394     MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
395     DataSet.Cancel;
396     DataAction := daAbort
397     end;
398     end;
399    
400     end.
401 tony 27