ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/dbcontrolgrid/unit1.pas
Revision: 45
Committed: Tue Dec 6 10:33:46 2016 UTC (7 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 10304 byte(s)
Log Message:
Committing updates for Release R2-0-0

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, DBControlGrid, types;
12
13 type
14
15 { TForm1 }
16
17 TForm1 = class(TForm)
18 EditLocationAction: TAction;
19 EditJobCodeAction: TAction;
20 DBEdit6: TDBEdit;
21 DBControlGrid1: TDBControlGrid;
22 DBEdit7: TDBEdit;
23 DBEdit8: TDBEdit;
24 DBText1: TDBText;
25 EmployeesDEPT_KEY_PATH: TIBStringField;
26 EmployeesDEPT_PATH: TIBStringField;
27 EmployeesJOB_TITLE: TIBStringField;
28 SelectDept: TAction;
29 Button4: TButton;
30 Button5: TButton;
31 CancelChanges: TAction;
32 SalaryRange: TComboBox;
33 BeforeDate: TDateEdit;
34 AfterDate: TDateEdit;
35 DBEdit1: TDBEdit;
36 DBEdit2: TDBEdit;
37 DBEdit3: TDBEdit;
38 DBEdit4: TDBEdit;
39 DBEdit5: TDBEdit;
40 Employees: TIBDataSet;
41 EmployeesDEPT_NO: TIBStringField;
42 EmployeesEMP_NO: TSmallintField;
43 EmployeesFIRST_NAME: TIBStringField;
44 EmployeesFULL_NAME: TIBStringField;
45 EmployeesHIRE_DATE: TDateTimeField;
46 EmployeesJOB_CODE: TIBStringField;
47 EmployeesJOB_COUNTRY: TIBStringField;
48 EmployeesJOB_GRADE: TSmallintField;
49 EmployeesLAST_NAME: TIBStringField;
50 EmployeesPHONE_EXT: TIBStringField;
51 EmployeesSALARY: TIBBCDField;
52 IBDateEdit1: TDBDateEdit;
53 JobGradeDBComboBox: TDBComboBox;
54 Label10: TLabel;
55 Label11: TLabel;
56 Label12: TLabel;
57 Label13: TLabel;
58 Label3: TLabel;
59 Label4: TLabel;
60 Label5: TLabel;
61 Label6: TLabel;
62 Label7: TLabel;
63 Label8: TLabel;
64 Label9: TLabel;
65 Panel1: TPanel;
66 Panel2: TPanel;
67 EmployeeEditorPanel: TPanel;
68 SpeedButton1: TSpeedButton;
69 SpeedButton2: TSpeedButton;
70 SpeedButton3: TSpeedButton;
71 TotalsQuery: TIBQuery;
72 TotalsQueryTOTALSALARIES: TIBBCDField;
73 Label1: TLabel;
74 Label2: TLabel;
75 SaveChanges: TAction;
76 DeleteEmployee: TAction;
77 EditEmployee: TAction;
78 AddEmployee: TAction;
79 ActionList1: TActionList;
80 Button1: TButton;
81 Button3: TButton;
82 EmployeeSource: TDataSource;
83 IBDatabase1: TIBDatabase;
84 IBTransaction1: TIBTransaction;
85 TotalsSource: TDataSource;
86 procedure EditJobCodeActionExecute(Sender: TObject);
87 procedure EditJobCodeActionUpdate(Sender: TObject);
88 procedure EditLocationActionExecute(Sender: TObject);
89 procedure EmployeesAfterPost(DataSet: TDataSet);
90 procedure JobGradeDBComboBoxCloseUp(Sender: TObject);
91 procedure SelectDeptExecute(Sender: TObject);
92 procedure AddEmployeeExecute(Sender: TObject);
93 procedure BeforeDateChange(Sender: TObject);
94 procedure CancelChangesExecute(Sender: TObject);
95 procedure DeleteEmployeeExecute(Sender: TObject);
96 procedure EditEmployeeUpdate(Sender: TObject);
97 procedure EmployeesAfterInsert(DataSet: TDataSet);
98 procedure EmployeesAfterOpen(DataSet: TDataSet);
99 procedure EmployeesBeforeClose(DataSet: TDataSet);
100 procedure EmployeesBeforeOpen(DataSet: TDataSet);
101 procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
102 procedure FormShow(Sender: TObject);
103 procedure EmployeesAfterDelete(DataSet: TDataSet);
104 procedure EmployeesAfterTransactionEnd(Sender: TObject);
105 procedure EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
106 var DataAction: TDataAction);
107 procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
108 DisplayText: Boolean);
109 procedure SaveChangesExecute(Sender: TObject);
110 procedure SaveChangesUpdate(Sender: TObject);
111 procedure TotalsQueryTOTALSALARIESGetText(Sender: TField;
112 var aText: string; DisplayText: Boolean);
113 private
114 { private declarations }
115 FDirty: boolean;
116 FClosing: boolean;
117 procedure Reopen(Data: PtrInt);
118 public
119 { public declarations }
120 end;
121
122 var
123 Form1: TForm1;
124
125 implementation
126
127 {$R *.lfm}
128
129 uses IB, Unit2, Unit4, Unit5;
130
131 const sNoName = '<no name>';
132
133 function ExtractDBException(msg: string): string;
134 var Lines: TStringList;
135 begin
136 Lines := TStringList.Create;
137 try
138 Lines.Text := msg;
139 if pos('exception',Lines[0]) = 1 then
140 Result := Lines[2]
141 else
142 Result := msg
143 finally
144 Lines.Free
145 end;
146 end;
147
148 { TForm1 }
149
150 procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
151 DisplayText: Boolean);
152 begin
153 if DisplayText then
154 begin
155 if Sender.IsNUll then
156 aText := ''
157 else
158 aText := FormatFloat('$#,##0.00',Sender.AsFloat)
159 end
160 else
161 aText := Sender.AsString
162 end;
163
164 procedure TForm1.SaveChangesExecute(Sender: TObject);
165 begin
166 Employees.Transaction.Commit
167 end;
168
169 procedure TForm1.SaveChangesUpdate(Sender: TObject);
170 begin
171 (Sender as TAction).Enabled := FDirty
172 end;
173
174 procedure TForm1.TotalsQueryTOTALSALARIESGetText(Sender: TField;
175 var aText: string; DisplayText: Boolean);
176 begin
177 if DisplayText then
178 begin
179 if Sender.IsNUll then
180 aText := ''
181 else
182 aText := FormatFloat('Total Salary Bill = $#,##0.00',Sender.AsFloat)
183 end
184 else
185 aText := Sender.AsString
186 end;
187
188 procedure TForm1.Reopen(Data: PtrInt);
189 begin
190 with IBTransaction1 do
191 if not InTransaction then StartTransaction;
192 Employees.Active := true;
193 end;
194
195 procedure TForm1.AddEmployeeExecute(Sender: TObject);
196 begin
197 Employees.Append;
198 DBControlGrid1.SetFocus;
199 end;
200
201 procedure TForm1.SelectDeptExecute(Sender: TObject);
202 var Dept_No: string;
203 begin
204 if SelectDeptDlg.ShowModal(EmployeesDEPT_KEY_PATH.AsString,Dept_No) = mrOK then
205 begin
206 Employees.Edit;
207 EmployeesDEPT_NO.AsString := Dept_No;
208 try
209 Employees.Post;
210 except
211 Employees.Cancel;
212 raise;
213 end;
214 end;
215 end;
216
217 procedure TForm1.EmployeesAfterPost(DataSet: TDataSet);
218 begin
219 Employees.Refresh
220 end;
221
222 procedure TForm1.EditJobCodeActionUpdate(Sender: TObject);
223 begin
224 (Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0 )
225 end;
226
227 procedure TForm1.EditLocationActionExecute(Sender: TObject);
228 var Country: string;
229 begin
230 Country := EmployeesJOB_COUNTRY.AsString;
231 if EditLocation.ShowModal(EmployeesJOB_GRADE.AsInteger, EmployeesJOB_CODE.AsString,
232 Country) = mrOK then
233 begin
234 Employees.Edit;
235 try
236 EmployeesJOB_COUNTRY.AsString := Country;
237 Employees.Post;
238 except
239 Employees.Cancel;
240 raise
241 end;
242 end;
243 end;
244
245 procedure TForm1.EditJobCodeActionExecute(Sender: TObject);
246 var JobCode: string;
247 begin
248 JobCode := EmployeesJOB_CODE.AsString;
249 if EditJobCode.ShowModal(EmployeesJOB_GRADE.AsInteger,EmployeesJOB_COUNTRY.AsString,
250 JobCode) = mrOK then
251 begin
252 Employees.Edit;
253 try
254 EmployeesJOB_CODE.AsString := JobCode;
255 Employees.Post;
256 except
257 Employees.Cancel;
258 raise
259 end;
260 end;
261 end;
262
263 procedure TForm1.JobGradeDBComboBoxCloseUp(Sender: TObject);
264 begin
265 JobGradeDBComboBox.EditingDone; //See http://bugs.freepascal.org/view.php?id=27186
266 end;
267
268 procedure TForm1.BeforeDateChange(Sender: TObject);
269 begin
270 Employees.Active := false;
271 Employees.Active := true
272 end;
273
274 procedure TForm1.CancelChangesExecute(Sender: TObject);
275 begin
276 Employees.Transaction.Rollback
277 end;
278
279 procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
280 begin
281 if MessageDlg(
282 Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
283 mtConfirmation,[mbYes,mbNo],0) = mrYes then
284 Employees.Delete;
285 DBControlGrid1.SetFocus;
286 end;
287
288 procedure TForm1.EditEmployeeUpdate(Sender: TObject);
289 begin
290 (Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
291 end;
292
293 procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
294 begin
295 EmployeesJOB_COUNTRY.AsString := 'USA';
296 EmployeesJOB_CODE.AsString := 'SRep';
297 EmployeesJOB_GRADE.AsInteger := 4;
298 EmployeesSALARY.AsCurrency := 20000;
299 EmployeesFIRST_NAME.AsString := sNoName;
300 EmployeesLAST_NAME.AsString := sNoName;
301 EmployeesHIRE_DATE.AsDateTime := now;
302 EmployeesDEPT_NO.AsString := '000';
303 FDirty := true;
304 end;
305
306 procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
307 begin
308 TotalsQuery.Active := true;
309 DBControlGrid1.SetFocus;
310 end;
311
312 procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
313 begin
314 TotalsQuery.Active := false
315 end;
316
317 procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
318 begin
319 if BeforeDate.Date > 0 then
320 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE < :BeforeDate');
321 if AfterDate.Date > 0 then
322 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE > :AfterDate');
323
324 case SalaryRange.ItemIndex of
325 1:
326 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary < 40000');
327 2:
328 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 40000 and Salary < 100000');
329 3:
330 (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 100000');
331 end;
332
333
334
335 {Parameter value must be set after all SQL changes have been made}
336 if BeforeDate.Date > 0 then
337 (DataSet as TIBParserDataSet).ParamByName('BeforeDate').AsDateTime := BeforeDate.Date;
338 if AfterDate.Date > 0 then
339 (DataSet as TIBParserDataSet).ParamByName('AfterDate').AsDateTime := AfterDate.Date;
340
341 end;
342
343 procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
344 begin
345 FClosing := true;
346 if IBTransaction1.InTransaction then
347 IBTransaction1.Commit;
348 end;
349
350 procedure TForm1.FormShow(Sender: TObject);
351 begin
352 repeat
353 try
354 IBDatabase1.Connected := true;
355 except
356 on E:EIBClientError do
357 begin
358 Close;
359 Exit
360 end;
361 On E:Exception do
362 MessageDlg(E.Message,mtError,[mbOK],0);
363 end;
364 until IBDatabase1.Connected;
365 Application.QueueAsyncCall(@Reopen,0);
366 end;
367
368 procedure TForm1.EmployeesAfterDelete(DataSet: TDataSet);
369 begin
370 FDirty := true
371 end;
372
373 procedure TForm1.EmployeesAfterTransactionEnd(Sender: TObject);
374 begin
375 FDirty := false;
376 if not FClosing then
377 Application.QueueAsyncCall(@Reopen,0)
378 end;
379
380 procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
381 var DataAction: TDataAction);
382 begin
383 if E is EIBError then
384 begin
385 MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
386 DataSet.Cancel;
387 DataAction := daAbort
388 end;
389 end;
390
391 end.
392