ViewVC Help

View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing

root/public/ibx/trunk/examples/employee/unit1.pas

Comparing ibx/trunk/examples/employee/unit1.pas (file contents):
Revision 27 by tony, Tue Apr 14 13:10:23 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	<	TotalsQueryTOTALSALARIES: TIBBCDField;
84	<	TotalsSource: TDataSource;
85	<	TotalsQuery: TIBQuery;
86	<	Label1: TLabel;
87	<	Label2: TLabel;
88	<	SaveChanges: TAction;
89	<	DeleteEmployee: TAction;
90	<	EditEmployee: TAction;
91	<	AddEmployee: TAction;
92	<	ActionList1: TActionList;
93	<	Button1: TButton;
94	<	Button2: TButton;
95	<	Button3: TButton;
96	<	EmployeeSource: TDataSource;
97	<	IBDatabase1: TIBDatabase;
98	<	IBTransaction1: TIBTransaction;
99	<	procedure EmployeesAfterPost(DataSet: TDataSet);
100	<	procedure EmployeesValidatePost(Sender: TObject; var CancelPost: boolean);
101	<	procedure JobGradeDBComboBoxCloseUp(Sender: TObject);
102	<	procedure SelectDeptExecute(Sender: TObject);
103	<	procedure AddEmployeeExecute(Sender: TObject);
104	<	procedure BeforeDateChange(Sender: TObject);
105	<	procedure CancelChangesExecute(Sender: TObject);
106	<	procedure CountriesBeforeOpen(DataSet: TDataSet);
107	<	procedure DeleteEmployeeExecute(Sender: TObject);
108	<	procedure EditEmployeeExecute(Sender: TObject);
109	<	procedure EditEmployeeUpdate(Sender: TObject);
110	<	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	<	procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
118	<	procedure FormShow(Sender: TObject);
119	<	procedure EmployeesAfterDelete(DataSet: TDataSet);
120	<	procedure EmployeesAfterTransactionEnd(Sender: TObject);
121	<	procedure EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
122	<	var DataAction: TDataAction);
123	<	procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
124	<	DisplayText: Boolean);
125	<	procedure JobCodesBeforeOpen(DataSet: TDataSet);
126	<	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	<	uses IB, Unit2;
145	<
146	<	const
147	<	sNoName = '<no name>';
148	<
149	<	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	<	procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
167	<	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	<	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	<	procedure TForm1.SaveChangesExecute(Sender: TObject);
187	<	begin
188	<	Employees.Transaction.Commit
189	<	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	<	Countries.Active := true;
201	<	Employees.Active := true;
202	<	JobCodes.Active := true;
203	<	Depts.Active := true;
204	<	end;
205	<
206	<	procedure TForm1.AddEmployeeExecute(Sender: TObject);
207	<	begin
208	<	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	<	begin
216	<	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	<	end;
226	<	end;
227	<
228	<	procedure TForm1.EmployeesAfterPost(DataSet: TDataSet);
229	<	begin
230	<	Employees.Refresh
231	<	end;
232	<
233	<	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	<	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	<	procedure TForm1.CancelChangesExecute(Sender: TObject);
252	<	begin
253	<	Employees.Transaction.Rollback
254	<	end;
255	<
256	<	procedure TForm1.CountriesBeforeOpen(DataSet: TDataSet);
257	<	begin
258	<	Countries.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
259	<	Countries.ParamByName('JOB_CODE').AsString := EmployeesJOB_CODE.AsString
260	<	end;
261	<
262	<	procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
263	<	begin
264	<	if MessageDlg(
265	<	Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
266	<	mtConfirmation,[mbYes,mbNo],0) = mrYes then
267	<	Employees.Delete
268	<	end;
269	<
270	<	procedure TForm1.EditEmployeeExecute(Sender: TObject);
271	<	begin
272	<	IBDynamicGrid1.ShowEditorPanel;
273	<	end;
274	<
275	<	procedure TForm1.EditEmployeeUpdate(Sender: TObject);
276	<	begin
277	<	(Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
278	<	end;
279	<
280	<	procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
281	<	begin
282	<	EmployeesJOB_COUNTRY.AsString := 'USA';
283	<	EmployeesJOB_CODE.AsString := 'SRep';
284	<	EmployeesJOB_GRADE.AsInteger := 4;
285	<	EmployeesSALARY.AsCurrency := 20000;
286	<	EmployeesFIRST_NAME.AsString := sNoName;
287	<	EmployeesLAST_NAME.AsString := sNoName;
288	<	EmployeesHIRE_DATE.AsDateTime := now;
289	<	EmployeesDEPT_NO.AsString := '000';
290	<	FDirty := true;
291	<	end;
292	<
293	<	procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
294	<	begin
295	<	TotalsQuery.Active := true;
296	<	IBDynamicGrid1.SetFocus;
297	<	end;
298	<
299	<	procedure TForm1.EmployeesAfterScroll(DataSet: TDataSet);
300	<	begin
301	<	Countries.Active := false;
302	<	JobCodes.Active := false;
303	<	Countries.Active := true;
304	<	JobCodes.Active := true;
305	<	end;
306	<
307	<	procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
308	<	begin
309	<	TotalsQuery.Active := false
310	<	end;
311	<
312	<	procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
313	<	begin
314	<	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	<	end;
337	<
338	<	procedure TForm1.EmployeesJOB_CODEChange(Sender: TField);
339	<	begin
340	<	Countries.Active := false;
341	<	Countries.Active := true;
342	<	end;
343	<
344	<	procedure TForm1.EmployeesJOB_GRADEChange(Sender: TField);
345	<	begin
346	<	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	<	FDirty := false;
385	<	if not FClosing then
386	<	Application.QueueAsyncCall(@Reopen,0)
387	<	end;
388	<
389	<	procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
390	<	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	<
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