examples/isqlmonitor/MainForm.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*) 
            
unit MainForm;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, DBGrids,
  StdCtrls, ActnList, EditBtn, DbCtrls, ExtCtrls, Buttons, IBDatabase, IBQuery,
  IBCustomDataSet, IBUpdateSQL, IBDynamicGrid, IBLookupComboEditBox,
  db, DBExtCtrls;

type

  { TForm1 }

  TForm1 = class(TForm)
    DBEdit6: TDBEdit;
    EmployeesDEPT_KEY_PATH: TIBStringField;
    EmployeesDEPT_PATH: TIBStringField;
    IBLookupComboEditBox1: TIBLookupComboEditBox;
    IBLookupComboEditBox2: TIBLookupComboEditBox;
    IBQuery1DEPT_NO: TIBStringField;
    IBQuery1EMP_NO: TSmallintField;
    IBQuery1FIRST_NAME: TIBStringField;
    IBQuery1FULL_NAME: TIBStringField;
    IBQuery1HIRE_DATE: TDateTimeField;
    IBQuery1JOB_CODE: TIBStringField;
    IBQuery1JOB_COUNTRY: TIBStringField;
    IBQuery1JOB_GRADE: TSmallintField;
    IBQuery1LAST_NAME: TIBStringField;
    IBQuery1PHONE_EXT: TIBStringField;
    IBQuery1SALARY: TIBBCDField;
    SelectDept: TAction;
    Button4: TButton;
    Button5: TButton;
    CancelChanges: TAction;
    SalaryRange: TComboBox;
    CountrySource: TDataSource;
    BeforeDate: TDateEdit;
    AfterDate: TDateEdit;
    DeptsSource: TDataSource;
    Depts: TIBQuery;
    JobCodeSource: TDataSource;
    DBEdit1: TDBEdit;
    DBEdit2: TDBEdit;
    DBEdit3: TDBEdit;
    DBEdit4: TDBEdit;
    DBEdit5: TDBEdit;
    DBText1: TDBText;
    Employees: TIBDataSet;
    EmployeesDEPT_NO: TIBStringField;
    EmployeesEMP_NO: TSmallintField;
    EmployeesFIRST_NAME: TIBStringField;
    EmployeesFULL_NAME: TIBStringField;
    EmployeesHIRE_DATE: TDateTimeField;
    EmployeesJOB_CODE: TIBStringField;
    EmployeesJOB_COUNTRY: TIBStringField;
    EmployeesJOB_GRADE: TSmallintField;
    EmployeesLAST_NAME: TIBStringField;
    EmployeesPHONE_EXT: TIBStringField;
    EmployeesSALARY: TIBBCDField;
    IBDateEdit1: TDBDateEdit;
    IBDynamicGrid1: TIBDynamicGrid;
    Countries: TIBQuery;
    JobCodes: TIBQuery;
    JobGradeDBComboBox: TDBComboBox;
    Label10: TLabel;
    Label11: TLabel;
    Label12: TLabel;
    Label13: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    Panel1: TPanel;
    Panel2: TPanel;
    EmployeeEditorPanel: TPanel;
    SpeedButton1: TSpeedButton;
    JobGradeChangeTimer: TTimer;
    JobCodeChangeTimer: TTimer;
    TotalsQueryTOTALSALARIES: TIBBCDField;
    TotalsSource: TDataSource;
    TotalsQuery: TIBQuery;
    Label1: TLabel;
    Label2: TLabel;
    SaveChanges: TAction;
    DeleteEmployee: TAction;
    EditEmployee: TAction;
    AddEmployee: TAction;
    ActionList1: TActionList;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    EmployeeSource: TDataSource;
    IBDatabase1: TIBDatabase;
    IBTransaction1: TIBTransaction;
    procedure EmployeesAfterPost(DataSet: TDataSet);
    procedure EmployeesValidatePost(Sender: TObject; var CancelPost: boolean);
    procedure JobCodeChangeTimerTimer(Sender: TObject);
    procedure JobGradeChangeTimerTimer(Sender: TObject);
    procedure JobGradeDBComboBoxCloseUp(Sender: TObject);
    procedure SelectDeptExecute(Sender: TObject);
    procedure AddEmployeeExecute(Sender: TObject);
    procedure BeforeDateChange(Sender: TObject);
    procedure CancelChangesExecute(Sender: TObject);
    procedure CountriesBeforeOpen(DataSet: TDataSet);
    procedure DeleteEmployeeExecute(Sender: TObject);
    procedure EditEmployeeExecute(Sender: TObject);
    procedure EditEmployeeUpdate(Sender: TObject);
    procedure EmployeesAfterInsert(DataSet: TDataSet);
    procedure EmployeesAfterOpen(DataSet: TDataSet);
    procedure EmployeesAfterScroll(DataSet: TDataSet);
    procedure EmployeesBeforeClose(DataSet: TDataSet);
    procedure EmployeesBeforeOpen(DataSet: TDataSet);
    procedure EmployeesJOB_CODEChange(Sender: TField);
    procedure EmployeesJOB_GRADEChange(Sender: TField);
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure EmployeesAfterDelete(DataSet: TDataSet);
    procedure EmployeesAfterTransactionEnd(Sender: TObject);
    procedure EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
      var DataAction: TDataAction);
    procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
      DisplayText: Boolean);
    procedure JobCodesBeforeOpen(DataSet: TDataSet);
    procedure SaveChangesExecute(Sender: TObject);
    procedure SaveChangesUpdate(Sender: TObject);
  private
    { private declarations }
    FDirty: boolean;
    FClosing: boolean;
    procedure Reopen(Data: PtrInt);
    procedure DoOpenDatabase(Data: PtrInt);
  public
    { public declarations }
  end; 

var
  Form1: TForm1; 

implementation

{$R *.lfm}

uses IB, SelectDeptDlgUnit,MonitorFormUnit;

const
  sNoName = '<no name>';

function ExtractDBException(msg: string): string;
var Lines: TStringList;
begin
     Lines := TStringList.Create;
     try
       Lines.Text := msg;
       if pos('exception',Lines[0]) = 1 then
         Result := Lines[2]
       else
         Result := msg
     finally
       Lines.Free
     end;
end;

{ TForm1 }

procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
  DisplayText: Boolean);
begin
  if DisplayText then
  begin
    if Sender.IsNUll then
      aText := ''
    else
      aText := FormatFloat('$#,##0.00',Sender.AsFloat)
  end
  else
    aText := Sender.AsString
end;

procedure TForm1.JobCodesBeforeOpen(DataSet: TDataSet);
begin
  JobCodes.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
  JobCodes.ParamByName('JOB_COUNTRY').AsString := EmployeesJOB_COUNTRY.AsString
end;

procedure TForm1.SaveChangesExecute(Sender: TObject);
begin
  Employees.Transaction.Commit
end;

procedure TForm1.SaveChangesUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := FDirty
end;

procedure TForm1.Reopen(Data: PtrInt);
begin
  with IBTransaction1 do
    if not InTransaction then StartTransaction;
  Countries.Active := true;
  Employees.Active := true;
  JobCodes.Active := true;
  Depts.Active := true;
end;

procedure TForm1.DoOpenDatabase(Data: PtrInt);
begin
  repeat
    try
      IBDatabase1.Connected := true;
    except
     on E:EIBClientError do
      begin
        Close;
        Exit
      end;
    On E:Exception do
     MessageDlg(E.Message,mtError,[mbOK],0);
    end;
  until IBDatabase1.Connected;
  Reopen(0);
  MonitorForm.BringToFront;
end;

procedure TForm1.AddEmployeeExecute(Sender: TObject);
begin
  Employees.Append
end;

procedure TForm1.SelectDeptExecute(Sender: TObject);
var Dept_No: string;
begin
  if SelectDeptDlg.ShowModal(EmployeesDEPT_KEY_PATH.AsString,Dept_No) = mrOK then
  begin
    Employees.Edit;
    EmployeesDEPT_NO.AsString := Dept_No;
    try
      Employees.Post;
    except
      Employees.Cancel;
      raise;
    end;
    IBDynamicGrid1.ShowEditorPanel;
  end;
end;

procedure TForm1.EmployeesAfterPost(DataSet: TDataSet);
begin
  Employees.Refresh
end;

procedure TForm1.EmployeesValidatePost(Sender: TObject; var CancelPost: boolean
  );
begin
  {Cancel if no name entered}
  CancelPost := (EmployeesLAST_NAME.AsString = sNoName) and  (EmployeesFIRST_NAME.AsString = sNoName);
end;

procedure TForm1.JobCodeChangeTimerTimer(Sender: TObject);
begin
  Countries.Active := false;
  Countries.Active := true;
  JobCodeChangeTimer.Interval := 0;
end;

procedure TForm1.JobGradeChangeTimerTimer(Sender: TObject);
begin
  Countries.Active := false;
  JobCodes.Active := false;
  Countries.Active := true;
  JobCodes.Active := true;
  JobGradeChangeTimer.Interval := 0;
end;

procedure TForm1.JobGradeDBComboBoxCloseUp(Sender: TObject);
begin
  JobGradeDBComboBox.EditingDone; //See http://bugs.freepascal.org/view.php?id=27186
end;

procedure TForm1.BeforeDateChange(Sender: TObject);
begin
  Employees.Active := false;
  Employees.Active := true
end;

procedure TForm1.CancelChangesExecute(Sender: TObject);
begin
  Employees.Transaction.Rollback
end;

procedure TForm1.CountriesBeforeOpen(DataSet: TDataSet);
begin
  Countries.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
  Countries.ParamByName('JOB_CODE').AsString := EmployeesJOB_CODE.AsString
end;

procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
begin
  if MessageDlg(
    Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
    mtConfirmation,[mbYes,mbNo],0) = mrYes then
    Employees.Delete
end;

procedure TForm1.EditEmployeeExecute(Sender: TObject);
begin
  IBDynamicGrid1.ShowEditorPanel;
end;

procedure TForm1.EditEmployeeUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
end;

procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
begin
  EmployeesJOB_COUNTRY.AsString := 'USA';
  EmployeesJOB_CODE.AsString := 'SRep';
  EmployeesJOB_GRADE.AsInteger := 4;
  EmployeesSALARY.AsCurrency := 20000;
  EmployeesFIRST_NAME.AsString := sNoName;
  EmployeesLAST_NAME.AsString := sNoName;
  EmployeesHIRE_DATE.AsDateTime := now;
  EmployeesDEPT_NO.AsString := '000';
  FDirty := true;
end;

procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
begin
  TotalsQuery.Active := true;
  IBDynamicGrid1.SetFocus;
end;

procedure TForm1.EmployeesAfterScroll(DataSet: TDataSet);
begin
  JobGradeChangeTimer.Interval := 200;
end;

procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
begin
  TotalsQuery.Active := false
end;

procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
begin
  if BeforeDate.Date > 0 then
     (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE < :BeforeDate');
  if AfterDate.Date > 0 then
     (DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE > :AfterDate');

  case SalaryRange.ItemIndex of
  1:
    (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary < 40000');
  2:
    (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 40000 and Salary < 100000');
  3:
    (DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 100000');
  end;


  {Parameter value must be set after all SQL changes have been made}
  if BeforeDate.Date > 0 then
     (DataSet as TIBParserDataSet).ParamByName('BeforeDate').AsDateTime := BeforeDate.Date;
  if AfterDate.Date > 0 then
   (DataSet as TIBParserDataSet).ParamByName('AfterDate').AsDateTime := AfterDate.Date;

end;

procedure TForm1.EmployeesJOB_CODEChange(Sender: TField);
begin
  JobCodeChangeTimer.Interval := 200;
end;

procedure TForm1.EmployeesJOB_GRADEChange(Sender: TField);
begin
  JobGradeChangeTimer.Interval := 200;
end;

procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  FClosing := true;
  if IBTransaction1.InTransaction then
    IBTransaction1.Commit;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  MonitorForm.Visible := true;
  Application.QueueAsyncCall(@DoOpenDatabase,0);
end;

procedure TForm1.EmployeesAfterDelete(DataSet: TDataSet);
begin
  FDirty := true
end;

procedure TForm1.EmployeesAfterTransactionEnd(Sender: TObject);
begin
  FDirty := false;
  if not FClosing then
    Application.QueueAsyncCall(@Reopen,0)
end;

procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
  var DataAction: TDataAction);
begin
  if E is EIBError then
   begin
       MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
       DataSet.Cancel;
       DataAction  := daAbort
   end;
end;

end.

Revision:	143
Committed:	Fri Feb 23 12:11:21 2018 UTC (6 years, 2 months ago) by tony
Content type:	text/x-pascal
File size:	12332 byte(s)
Log Message:	Fixes Merged
#	Content
1	(*
2	* IBX For Lazarus (Firebird Express)
3	*
4	* The contents of this file are subject to the Initial Developer's
5	* Public License Version 1.0 (the "License"); you may not use this
6	* file except in compliance with the License. You may obtain a copy
7	* of the License here:
8	*
9	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10	*
11	* Software distributed under the License is distributed on an "AS
12	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13	* implied. See the License for the specific language governing rights
14	* and limitations under the License.
15	*
16	* The Initial Developer of the Original Code is Tony Whyman.
17	*
18	* The Original Code is (C) 2015 Tony Whyman, MWA Software
19	* (http://www.mwasoftware.co.uk).
20	*
21	* All Rights Reserved.
22	*
23	* Contributor(s): ______________________________________.
24	*
25	*)
26
27	unit MainForm;
28
29	{$mode objfpc}{$H+}
30
31	interface
32
33	uses
34	Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, DBGrids,
35	StdCtrls, ActnList, EditBtn, DbCtrls, ExtCtrls, Buttons, IBDatabase, IBQuery,
36	IBCustomDataSet, IBUpdateSQL, IBDynamicGrid, IBLookupComboEditBox,
37	db, DBExtCtrls;
38
39	type
40
41	{ TForm1 }
42
43	TForm1 = class(TForm)
44	DBEdit6: TDBEdit;
45	EmployeesDEPT_KEY_PATH: TIBStringField;
46	EmployeesDEPT_PATH: TIBStringField;
47	IBLookupComboEditBox1: TIBLookupComboEditBox;
48	IBLookupComboEditBox2: TIBLookupComboEditBox;
49	IBQuery1DEPT_NO: TIBStringField;
50	IBQuery1EMP_NO: TSmallintField;
51	IBQuery1FIRST_NAME: TIBStringField;
52	IBQuery1FULL_NAME: TIBStringField;
53	IBQuery1HIRE_DATE: TDateTimeField;
54	IBQuery1JOB_CODE: TIBStringField;
55	IBQuery1JOB_COUNTRY: TIBStringField;
56	IBQuery1JOB_GRADE: TSmallintField;
57	IBQuery1LAST_NAME: TIBStringField;
58	IBQuery1PHONE_EXT: TIBStringField;
59	IBQuery1SALARY: TIBBCDField;
60	SelectDept: TAction;
61	Button4: TButton;
62	Button5: TButton;
63	CancelChanges: TAction;
64	SalaryRange: TComboBox;
65	CountrySource: TDataSource;
66	BeforeDate: TDateEdit;
67	AfterDate: TDateEdit;
68	DeptsSource: TDataSource;
69	Depts: TIBQuery;
70	JobCodeSource: TDataSource;
71	DBEdit1: TDBEdit;
72	DBEdit2: TDBEdit;
73	DBEdit3: TDBEdit;
74	DBEdit4: TDBEdit;
75	DBEdit5: TDBEdit;
76	DBText1: TDBText;
77	Employees: TIBDataSet;
78	EmployeesDEPT_NO: TIBStringField;
79	EmployeesEMP_NO: TSmallintField;
80	EmployeesFIRST_NAME: TIBStringField;
81	EmployeesFULL_NAME: TIBStringField;
82	EmployeesHIRE_DATE: TDateTimeField;
83	EmployeesJOB_CODE: TIBStringField;
84	EmployeesJOB_COUNTRY: TIBStringField;
85	EmployeesJOB_GRADE: TSmallintField;
86	EmployeesLAST_NAME: TIBStringField;
87	EmployeesPHONE_EXT: TIBStringField;
88	EmployeesSALARY: TIBBCDField;
89	IBDateEdit1: TDBDateEdit;
90	IBDynamicGrid1: TIBDynamicGrid;
91	Countries: TIBQuery;
92	JobCodes: TIBQuery;
93	JobGradeDBComboBox: TDBComboBox;
94	Label10: TLabel;
95	Label11: TLabel;
96	Label12: TLabel;
97	Label13: TLabel;
98	Label3: TLabel;
99	Label4: TLabel;
100	Label5: TLabel;
101	Label6: TLabel;
102	Label7: TLabel;
103	Label8: TLabel;
104	Label9: TLabel;
105	Panel1: TPanel;
106	Panel2: TPanel;
107	EmployeeEditorPanel: TPanel;
108	SpeedButton1: TSpeedButton;
109	JobGradeChangeTimer: TTimer;
110	JobCodeChangeTimer: TTimer;
111	TotalsQueryTOTALSALARIES: TIBBCDField;
112	TotalsSource: TDataSource;
113	TotalsQuery: TIBQuery;
114	Label1: TLabel;
115	Label2: TLabel;
116	SaveChanges: TAction;
117	DeleteEmployee: TAction;
118	EditEmployee: TAction;
119	AddEmployee: TAction;
120	ActionList1: TActionList;
121	Button1: TButton;
122	Button2: TButton;
123	Button3: TButton;
124	EmployeeSource: TDataSource;
125	IBDatabase1: TIBDatabase;
126	IBTransaction1: TIBTransaction;
127	procedure EmployeesAfterPost(DataSet: TDataSet);
128	procedure EmployeesValidatePost(Sender: TObject; var CancelPost: boolean);
129	procedure JobCodeChangeTimerTimer(Sender: TObject);
130	procedure JobGradeChangeTimerTimer(Sender: TObject);
131	procedure JobGradeDBComboBoxCloseUp(Sender: TObject);
132	procedure SelectDeptExecute(Sender: TObject);
133	procedure AddEmployeeExecute(Sender: TObject);
134	procedure BeforeDateChange(Sender: TObject);
135	procedure CancelChangesExecute(Sender: TObject);
136	procedure CountriesBeforeOpen(DataSet: TDataSet);
137	procedure DeleteEmployeeExecute(Sender: TObject);
138	procedure EditEmployeeExecute(Sender: TObject);
139	procedure EditEmployeeUpdate(Sender: TObject);
140	procedure EmployeesAfterInsert(DataSet: TDataSet);
141	procedure EmployeesAfterOpen(DataSet: TDataSet);
142	procedure EmployeesAfterScroll(DataSet: TDataSet);
143	procedure EmployeesBeforeClose(DataSet: TDataSet);
144	procedure EmployeesBeforeOpen(DataSet: TDataSet);
145	procedure EmployeesJOB_CODEChange(Sender: TField);
146	procedure EmployeesJOB_GRADEChange(Sender: TField);
147	procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
148	procedure FormShow(Sender: TObject);
149	procedure EmployeesAfterDelete(DataSet: TDataSet);
150	procedure EmployeesAfterTransactionEnd(Sender: TObject);
151	procedure EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
152	var DataAction: TDataAction);
153	procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
154	DisplayText: Boolean);
155	procedure JobCodesBeforeOpen(DataSet: TDataSet);
156	procedure SaveChangesExecute(Sender: TObject);
157	procedure SaveChangesUpdate(Sender: TObject);
158	private
159	{ private declarations }
160	FDirty: boolean;
161	FClosing: boolean;
162	procedure Reopen(Data: PtrInt);
163	procedure DoOpenDatabase(Data: PtrInt);
164	public
165	{ public declarations }
166	end;
167
168	var
169	Form1: TForm1;
170
171	implementation
172
173	{$R *.lfm}
174
175	uses IB, SelectDeptDlgUnit,MonitorFormUnit;
176
177	const
178	sNoName = '<no name>';
179
180	function ExtractDBException(msg: string): string;
181	var Lines: TStringList;
182	begin
183	Lines := TStringList.Create;
184	try
185	Lines.Text := msg;
186	if pos('exception',Lines[0]) = 1 then
187	Result := Lines[2]
188	else
189	Result := msg
190	finally
191	Lines.Free
192	end;
193	end;
194
195	{ TForm1 }
196
197	procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
198	DisplayText: Boolean);
199	begin
200	if DisplayText then
201	begin
202	if Sender.IsNUll then
203	aText := ''
204	else
205	aText := FormatFloat('$#,##0.00',Sender.AsFloat)
206	end
207	else
208	aText := Sender.AsString
209	end;
210
211	procedure TForm1.JobCodesBeforeOpen(DataSet: TDataSet);
212	begin
213	JobCodes.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
214	JobCodes.ParamByName('JOB_COUNTRY').AsString := EmployeesJOB_COUNTRY.AsString
215	end;
216
217	procedure TForm1.SaveChangesExecute(Sender: TObject);
218	begin
219	Employees.Transaction.Commit
220	end;
221
222	procedure TForm1.SaveChangesUpdate(Sender: TObject);
223	begin
224	(Sender as TAction).Enabled := FDirty
225	end;
226
227	procedure TForm1.Reopen(Data: PtrInt);
228	begin
229	with IBTransaction1 do
230	if not InTransaction then StartTransaction;
231	Countries.Active := true;
232	Employees.Active := true;
233	JobCodes.Active := true;
234	Depts.Active := true;
235	end;
236
237	procedure TForm1.DoOpenDatabase(Data: PtrInt);
238	begin
239	repeat
240	try
241	IBDatabase1.Connected := true;
242	except
243	on E:EIBClientError do
244	begin
245	Close;
246	Exit
247	end;
248	On E:Exception do
249	MessageDlg(E.Message,mtError,[mbOK],0);
250	end;
251	until IBDatabase1.Connected;
252	Reopen(0);
253	MonitorForm.BringToFront;
254	end;
255
256	procedure TForm1.AddEmployeeExecute(Sender: TObject);
257	begin
258	Employees.Append
259	end;
260
261	procedure TForm1.SelectDeptExecute(Sender: TObject);
262	var Dept_No: string;
263	begin
264	if SelectDeptDlg.ShowModal(EmployeesDEPT_KEY_PATH.AsString,Dept_No) = mrOK then
265	begin
266	Employees.Edit;
267	EmployeesDEPT_NO.AsString := Dept_No;
268	try
269	Employees.Post;
270	except
271	Employees.Cancel;
272	raise;
273	end;
274	IBDynamicGrid1.ShowEditorPanel;
275	end;
276	end;
277
278	procedure TForm1.EmployeesAfterPost(DataSet: TDataSet);
279	begin
280	Employees.Refresh
281	end;
282
283	procedure TForm1.EmployeesValidatePost(Sender: TObject; var CancelPost: boolean
284	);
285	begin
286	{Cancel if no name entered}
287	CancelPost := (EmployeesLAST_NAME.AsString = sNoName) and (EmployeesFIRST_NAME.AsString = sNoName);
288	end;
289
290	procedure TForm1.JobCodeChangeTimerTimer(Sender: TObject);
291	begin
292	Countries.Active := false;
293	Countries.Active := true;
294	JobCodeChangeTimer.Interval := 0;
295	end;
296
297	procedure TForm1.JobGradeChangeTimerTimer(Sender: TObject);
298	begin
299	Countries.Active := false;
300	JobCodes.Active := false;
301	Countries.Active := true;
302	JobCodes.Active := true;
303	JobGradeChangeTimer.Interval := 0;
304	end;
305
306	procedure TForm1.JobGradeDBComboBoxCloseUp(Sender: TObject);
307	begin
308	JobGradeDBComboBox.EditingDone; //See http://bugs.freepascal.org/view.php?id=27186
309	end;
310
311	procedure TForm1.BeforeDateChange(Sender: TObject);
312	begin
313	Employees.Active := false;
314	Employees.Active := true
315	end;
316
317	procedure TForm1.CancelChangesExecute(Sender: TObject);
318	begin
319	Employees.Transaction.Rollback
320	end;
321
322	procedure TForm1.CountriesBeforeOpen(DataSet: TDataSet);
323	begin
324	Countries.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
325	Countries.ParamByName('JOB_CODE').AsString := EmployeesJOB_CODE.AsString
326	end;
327
328	procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
329	begin
330	if MessageDlg(
331	Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
332	mtConfirmation,[mbYes,mbNo],0) = mrYes then
333	Employees.Delete
334	end;
335
336	procedure TForm1.EditEmployeeExecute(Sender: TObject);
337	begin
338	IBDynamicGrid1.ShowEditorPanel;
339	end;
340
341	procedure TForm1.EditEmployeeUpdate(Sender: TObject);
342	begin
343	(Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
344	end;
345
346	procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
347	begin
348	EmployeesJOB_COUNTRY.AsString := 'USA';
349	EmployeesJOB_CODE.AsString := 'SRep';
350	EmployeesJOB_GRADE.AsInteger := 4;
351	EmployeesSALARY.AsCurrency := 20000;
352	EmployeesFIRST_NAME.AsString := sNoName;
353	EmployeesLAST_NAME.AsString := sNoName;
354	EmployeesHIRE_DATE.AsDateTime := now;
355	EmployeesDEPT_NO.AsString := '000';
356	FDirty := true;
357	end;
358
359	procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
360	begin
361	TotalsQuery.Active := true;
362	IBDynamicGrid1.SetFocus;
363	end;
364
365	procedure TForm1.EmployeesAfterScroll(DataSet: TDataSet);
366	begin
367	JobGradeChangeTimer.Interval := 200;
368	end;
369
370	procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
371	begin
372	TotalsQuery.Active := false
373	end;
374
375	procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
376	begin
377	if BeforeDate.Date > 0 then
378	(DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE < :BeforeDate');
379	if AfterDate.Date > 0 then
380	(DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE > :AfterDate');
381
382	case SalaryRange.ItemIndex of
383	1:
384	(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary < 40000');
385	2:
386	(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 40000 and Salary < 100000');
387	3:
388	(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 100000');
389	end;
390
391
392
393	{Parameter value must be set after all SQL changes have been made}
394	if BeforeDate.Date > 0 then
395	(DataSet as TIBParserDataSet).ParamByName('BeforeDate').AsDateTime := BeforeDate.Date;
396	if AfterDate.Date > 0 then
397	(DataSet as TIBParserDataSet).ParamByName('AfterDate').AsDateTime := AfterDate.Date;
398
399	end;
400
401	procedure TForm1.EmployeesJOB_CODEChange(Sender: TField);
402	begin
403	JobCodeChangeTimer.Interval := 200;
404	end;
405
406	procedure TForm1.EmployeesJOB_GRADEChange(Sender: TField);
407	begin
408	JobGradeChangeTimer.Interval := 200;
409	end;
410
411	procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
412	begin
413	FClosing := true;
414	if IBTransaction1.InTransaction then
415	IBTransaction1.Commit;
416	end;
417
418	procedure TForm1.FormShow(Sender: TObject);
419	begin
420	MonitorForm.Visible := true;
421	Application.QueueAsyncCall(@DoOpenDatabase,0);
422	end;
423
424	procedure TForm1.EmployeesAfterDelete(DataSet: TDataSet);
425	begin
426	FDirty := true
427	end;
428
429	procedure TForm1.EmployeesAfterTransactionEnd(Sender: TObject);
430	begin
431	FDirty := false;
432	if not FClosing then
433	Application.QueueAsyncCall(@Reopen,0)
434	end;
435
436	procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
437	var DataAction: TDataAction);
438	begin
439	if E is EIBError then
440	begin
441	MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
442	DataSet.Cancel;
443	DataAction := daAbort
444	end;
445	end;
446
447	end.
448