examples/local-employeedb/unit1.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 Unit1; 

{$mode objfpc}{$H+}

interface

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

const
  RequiredVersionNo = 2;

type

  { TForm1 }

  TForm1 = class(TForm)
    CheckVersionTablePresent: TIBSQL;
    DBImage1: TDBImage;
    EmployeesPHOTO1: TBlobField;
    GetDBVersionNoQuery: TIBSQL;
    MenuItem6: TMenuItem;
    MenuItem7: TMenuItem;
    Panel3: TPanel;
    Quit: TAction;
    MainMenu1: TMainMenu;
    MenuItem1: TMenuItem;
    MenuItem2: TMenuItem;
    MenuItem3: TMenuItem;
    MenuItem4: TMenuItem;
    MenuItem5: TMenuItem;
    RestoreDatabase: TAction;
    SaveDatabase: TAction;
    NewDatabase: TAction;
    DBEdit6: TDBEdit;
    EmployeesDEPT_KEY_PATH: TIBStringField;
    EmployeesDEPT_PATH: TIBStringField;
    IBLocalDBSupport1: TIBLocalDBSupport;
    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 DBImage1DBImageRead(Sender: TObject; S: TStream;
      var GraphExt: string);
    procedure EmployeesValidatePost(Sender: TObject; var CancelPost: boolean);
    procedure IBDatabase1AfterConnect(Sender: TObject);
    procedure IBLocalDBSupport1GetDBVersionNo(Sender: TObject;
      var VersionNo: integer);
    procedure JobCodeChangeTimerTimer(Sender: TObject);
    procedure JobGradeChangeTimerTimer(Sender: TObject);
    procedure JobGradeDBComboBoxCloseUp(Sender: TObject);
    procedure NewDatabaseExecute(Sender: TObject);
    procedure QuitExecute(Sender: TObject);
    procedure RestoreDatabaseExecute(Sender: TObject);
    procedure SaveDatabaseExecute(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
    FCurrentDBVersion: integer;
    { private declarations }
    FDirty: boolean;
    FNoAutoReopen: boolean;
    procedure Reopen(Data: PtrInt);
    function GetDBVersionNo: integer;
  public
    { public declarations }
    property CurrentDBVersion: integer read FCurrentDBVersion;
  end; 

var
  Form1: TForm1;

implementation

{$R *.lfm}

uses IB, Unit2, FBMessages;

const
  sNoName = '<no name>';

{ 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;

function TForm1.GetDBVersionNo: integer;
begin
  FCurrentDBVersion := 0;
  Result := 0;
  FNoAutoReopen := true;
  try
    with IBTransaction1 do
      if not InTransaction then StartTransaction;
    try
      with CheckVersionTablePresent do
      begin
        ExecQuery;
        try
          if EOF then Exit;
        finally
          Close;
        end;
      end;

      with GetDBVersionNoQuery do
      begin
        ExecQuery;
        try
          Result := FieldByName('VersionNo').AsInteger;
          FCurrentDBVersion := Result;
        finally
          Close;
        end;
      end;
    finally
      IBTransaction1.Commit;
    end;
  finally
    FNoAutoReopen := false
  end;
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.DBImage1DBImageRead(Sender: TObject; S: TStream;
  var GraphExt: string);
begin
  GraphExt := 'png';
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.IBDatabase1AfterConnect(Sender: TObject);
begin
  with IBLocalDBSupport1 do
    if CurrentDBVersionNo = RequiredVersionNo  then
      ReOpen(0);
end;

procedure TForm1.IBLocalDBSupport1GetDBVersionNo(Sender: TObject;
  var VersionNo: integer);
begin
  VersionNo := GetDBVersionNo;
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.NewDatabaseExecute(Sender: TObject);
begin
  FNoAutoReopen := true;
  try
    {Ensure Transaction End}
    if IBTransaction1.InTransaction then
      IBTransaction1.Rollback;
  finally
    FNoAutoReopen := false;
  end;
  IBLocalDBSupport1.NewDatabase;
end;

procedure TForm1.QuitExecute(Sender: TObject);
begin
  Close;
end;

procedure TForm1.RestoreDatabaseExecute(Sender: TObject);
begin
  FNoAutoReopen := true;
  try
    {Ensure all changes saved}
    if IBTransaction1.InTransaction then
      IBTransaction1.Commit;
  finally
    FNoAutoReopen := false;
  end;
  IBLocalDBSupport1.RestoreDatabase;
end;

procedure TForm1.SaveDatabaseExecute(Sender: TObject);
begin
  FNoAutoReopen := true;
  try
    {Ensure all changes saved}
    if IBTransaction1.InTransaction then
      IBTransaction1.Commit;
  finally
    FNoAutoReopen := false;
  end;
  IBLocalDBSupport1.SaveDatabase;
  {Start new Transaction and open dataset}
  ReOpen(0);
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
  FNoAutoReopen := true;
  if IBTransaction1.InTransaction then
    IBTransaction1.Commit;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  {Set IB Exceptions to only show text message - omit SQLCode and Engine Code}
  IBDatabase1.FirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);
  Application.ExceptionDialog := aedOkMessageBox;
  try
    IBDatabase1.Connected := true;
  except On E:Exception do
    begin
     MessageDlg(E.Message,mtError,[mbOK],0);
     Close;
     Exit
    end;
  end;

  {If upgrade failed or downgrade not pending then exit}
  with IBLocalDBSupport1 do
    if (CurrentDBVersionNo < RequiredVersionNo) or
       ((CurrentDBVersionNo >  RequiredVersionNo) and not DowngradePending) then
    Close;
end;

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

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

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

end.

Revision:	263
Committed:	Thu Dec 6 15:55:01 2018 UTC (5 years, 11 months ago) by tony
Content type:	text/x-pascal
File size:	15208 byte(s)
Log Message:	Release 2.3.2 committed
#	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 Unit1;
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, IBSQL, IBDynamicGrid, IBLookupComboEditBox,
37	IBLocalDBSupport, db, DBExtCtrls, Menus;
38
39	const
40	RequiredVersionNo = 2;
41
42	type
43
44	{ TForm1 }
45
46	TForm1 = class(TForm)
47	CheckVersionTablePresent: TIBSQL;
48	DBImage1: TDBImage;
49	EmployeesPHOTO1: TBlobField;
50	GetDBVersionNoQuery: TIBSQL;
51	MenuItem6: TMenuItem;
52	MenuItem7: TMenuItem;
53	Panel3: TPanel;
54	Quit: TAction;
55	MainMenu1: TMainMenu;
56	MenuItem1: TMenuItem;
57	MenuItem2: TMenuItem;
58	MenuItem3: TMenuItem;
59	MenuItem4: TMenuItem;
60	MenuItem5: TMenuItem;
61	RestoreDatabase: TAction;
62	SaveDatabase: TAction;
63	NewDatabase: TAction;
64	DBEdit6: TDBEdit;
65	EmployeesDEPT_KEY_PATH: TIBStringField;
66	EmployeesDEPT_PATH: TIBStringField;
67	IBLocalDBSupport1: TIBLocalDBSupport;
68	IBLookupComboEditBox1: TIBLookupComboEditBox;
69	IBLookupComboEditBox2: TIBLookupComboEditBox;
70	IBQuery1DEPT_NO: TIBStringField;
71	IBQuery1EMP_NO: TSmallintField;
72	IBQuery1FIRST_NAME: TIBStringField;
73	IBQuery1FULL_NAME: TIBStringField;
74	IBQuery1HIRE_DATE: TDateTimeField;
75	IBQuery1JOB_CODE: TIBStringField;
76	IBQuery1JOB_COUNTRY: TIBStringField;
77	IBQuery1JOB_GRADE: TSmallintField;
78	IBQuery1LAST_NAME: TIBStringField;
79	IBQuery1PHONE_EXT: TIBStringField;
80	IBQuery1SALARY: TIBBCDField;
81	SelectDept: TAction;
82	Button4: TButton;
83	Button5: TButton;
84	CancelChanges: TAction;
85	SalaryRange: TComboBox;
86	CountrySource: TDataSource;
87	BeforeDate: TDateEdit;
88	AfterDate: TDateEdit;
89	DeptsSource: TDataSource;
90	Depts: TIBQuery;
91	JobCodeSource: TDataSource;
92	DBEdit1: TDBEdit;
93	DBEdit2: TDBEdit;
94	DBEdit3: TDBEdit;
95	DBEdit4: TDBEdit;
96	DBEdit5: TDBEdit;
97	DBText1: TDBText;
98	Employees: TIBDataSet;
99	EmployeesDEPT_NO: TIBStringField;
100	EmployeesEMP_NO: TSmallintField;
101	EmployeesFIRST_NAME: TIBStringField;
102	EmployeesFULL_NAME: TIBStringField;
103	EmployeesHIRE_DATE: TDateTimeField;
104	EmployeesJOB_CODE: TIBStringField;
105	EmployeesJOB_COUNTRY: TIBStringField;
106	EmployeesJOB_GRADE: TSmallintField;
107	EmployeesLAST_NAME: TIBStringField;
108	EmployeesPHONE_EXT: TIBStringField;
109	EmployeesSALARY: TIBBCDField;
110	IBDateEdit1: TDBDateEdit;
111	IBDynamicGrid1: TIBDynamicGrid;
112	Countries: TIBQuery;
113	JobCodes: TIBQuery;
114	JobGradeDBComboBox: TDBComboBox;
115	Label10: TLabel;
116	Label11: TLabel;
117	Label12: TLabel;
118	Label13: TLabel;
119	Label3: TLabel;
120	Label4: TLabel;
121	Label5: TLabel;
122	Label6: TLabel;
123	Label7: TLabel;
124	Label8: TLabel;
125	Label9: TLabel;
126	Panel1: TPanel;
127	Panel2: TPanel;
128	EmployeeEditorPanel: TPanel;
129	SpeedButton1: TSpeedButton;
130	JobGradeChangeTimer: TTimer;
131	JobCodeChangeTimer: TTimer;
132	TotalsQueryTOTALSALARIES: TIBBCDField;
133	TotalsSource: TDataSource;
134	TotalsQuery: TIBQuery;
135	Label1: TLabel;
136	Label2: TLabel;
137	SaveChanges: TAction;
138	DeleteEmployee: TAction;
139	EditEmployee: TAction;
140	AddEmployee: TAction;
141	ActionList1: TActionList;
142	Button1: TButton;
143	Button2: TButton;
144	Button3: TButton;
145	EmployeeSource: TDataSource;
146	IBDatabase1: TIBDatabase;
147	IBTransaction1: TIBTransaction;
148	procedure DBImage1DBImageRead(Sender: TObject; S: TStream;
149	var GraphExt: string);
150	procedure EmployeesValidatePost(Sender: TObject; var CancelPost: boolean);
151	procedure IBDatabase1AfterConnect(Sender: TObject);
152	procedure IBLocalDBSupport1GetDBVersionNo(Sender: TObject;
153	var VersionNo: integer);
154	procedure JobCodeChangeTimerTimer(Sender: TObject);
155	procedure JobGradeChangeTimerTimer(Sender: TObject);
156	procedure JobGradeDBComboBoxCloseUp(Sender: TObject);
157	procedure NewDatabaseExecute(Sender: TObject);
158	procedure QuitExecute(Sender: TObject);
159	procedure RestoreDatabaseExecute(Sender: TObject);
160	procedure SaveDatabaseExecute(Sender: TObject);
161	procedure SelectDeptExecute(Sender: TObject);
162	procedure AddEmployeeExecute(Sender: TObject);
163	procedure BeforeDateChange(Sender: TObject);
164	procedure CancelChangesExecute(Sender: TObject);
165	procedure CountriesBeforeOpen(DataSet: TDataSet);
166	procedure DeleteEmployeeExecute(Sender: TObject);
167	procedure EditEmployeeExecute(Sender: TObject);
168	procedure EditEmployeeUpdate(Sender: TObject);
169	procedure EmployeesAfterInsert(DataSet: TDataSet);
170	procedure EmployeesAfterOpen(DataSet: TDataSet);
171	procedure EmployeesAfterScroll(DataSet: TDataSet);
172	procedure EmployeesBeforeClose(DataSet: TDataSet);
173	procedure EmployeesBeforeOpen(DataSet: TDataSet);
174	procedure EmployeesJOB_CODEChange(Sender: TField);
175	procedure EmployeesJOB_GRADEChange(Sender: TField);
176	procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
177	procedure FormShow(Sender: TObject);
178	procedure EmployeesAfterDelete(DataSet: TDataSet);
179	procedure EmployeesAfterTransactionEnd(Sender: TObject);
180	procedure EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
181	var DataAction: TDataAction);
182	procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
183	DisplayText: Boolean);
184	procedure JobCodesBeforeOpen(DataSet: TDataSet);
185	procedure SaveChangesExecute(Sender: TObject);
186	procedure SaveChangesUpdate(Sender: TObject);
187	private
188	FCurrentDBVersion: integer;
189	{ private declarations }
190	FDirty: boolean;
191	FNoAutoReopen: boolean;
192	procedure Reopen(Data: PtrInt);
193	function GetDBVersionNo: integer;
194	public
195	{ public declarations }
196	property CurrentDBVersion: integer read FCurrentDBVersion;
197	end;
198
199	var
200	Form1: TForm1;
201
202	implementation
203
204	{$R *.lfm}
205
206	uses IB, Unit2, FBMessages;
207
208	const
209	sNoName = '<no name>';
210
211	{ TForm1 }
212
213	procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
214	DisplayText: Boolean);
215	begin
216	if DisplayText then
217	begin
218	if Sender.IsNUll then
219	aText := ''
220	else
221	aText := FormatFloat('$#,##0.00',Sender.AsFloat)
222	end
223	else
224	aText := Sender.AsString
225	end;
226
227	procedure TForm1.JobCodesBeforeOpen(DataSet: TDataSet);
228	begin
229	JobCodes.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
230	JobCodes.ParamByName('JOB_COUNTRY').AsString := EmployeesJOB_COUNTRY.AsString
231	end;
232
233	procedure TForm1.SaveChangesExecute(Sender: TObject);
234	begin
235	Employees.Transaction.Commit
236	end;
237
238	procedure TForm1.SaveChangesUpdate(Sender: TObject);
239	begin
240	(Sender as TAction).Enabled := FDirty
241	end;
242
243	procedure TForm1.Reopen(Data: PtrInt);
244	begin
245	with IBTransaction1 do
246	if not InTransaction then StartTransaction;
247	Countries.Active := true;
248	Employees.Active := true;
249	JobCodes.Active := true;
250	Depts.Active := true;
251	end;
252
253	function TForm1.GetDBVersionNo: integer;
254	begin
255	FCurrentDBVersion := 0;
256	Result := 0;
257	FNoAutoReopen := true;
258	try
259	with IBTransaction1 do
260	if not InTransaction then StartTransaction;
261	try
262	with CheckVersionTablePresent do
263	begin
264	ExecQuery;
265	try
266	if EOF then Exit;
267	finally
268	Close;
269	end;
270	end;
271
272	with GetDBVersionNoQuery do
273	begin
274	ExecQuery;
275	try
276	Result := FieldByName('VersionNo').AsInteger;
277	FCurrentDBVersion := Result;
278	finally
279	Close;
280	end;
281	end;
282	finally
283	IBTransaction1.Commit;
284	end;
285	finally
286	FNoAutoReopen := false
287	end;
288	end;
289
290
291	procedure TForm1.AddEmployeeExecute(Sender: TObject);
292	begin
293	Employees.Append
294	end;
295
296	procedure TForm1.SelectDeptExecute(Sender: TObject);
297	var Dept_No: string;
298	begin
299	if SelectDeptDlg.ShowModal(EmployeesDEPT_KEY_PATH.AsString,Dept_No) = mrOK then
300	begin
301	Employees.Edit;
302	EmployeesDEPT_NO.AsString := Dept_No;
303	try
304	Employees.Post;
305	except
306	Employees.Cancel;
307	raise;
308	end;
309	IBDynamicGrid1.ShowEditorPanel;
310	end;
311	end;
312
313	procedure TForm1.DBImage1DBImageRead(Sender: TObject; S: TStream;
314	var GraphExt: string);
315	begin
316	GraphExt := 'png';
317	end;
318
319	procedure TForm1.EmployeesValidatePost(Sender: TObject; var CancelPost: boolean
320	);
321	begin
322	{Cancel if no name entered}
323	CancelPost := (EmployeesLAST_NAME.AsString = sNoName) and (EmployeesFIRST_NAME.AsString = sNoName);
324	end;
325
326	procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
327	begin
328	with IBLocalDBSupport1 do
329	if CurrentDBVersionNo = RequiredVersionNo then
330	ReOpen(0);
331	end;
332
333	procedure TForm1.IBLocalDBSupport1GetDBVersionNo(Sender: TObject;
334	var VersionNo: integer);
335	begin
336	VersionNo := GetDBVersionNo;
337	end;
338
339	procedure TForm1.JobCodeChangeTimerTimer(Sender: TObject);
340	begin
341	Countries.Active := false;
342	Countries.Active := true;
343	JobCodeChangeTimer.Interval := 0;
344	end;
345
346	procedure TForm1.JobGradeChangeTimerTimer(Sender: TObject);
347	begin
348	Countries.Active := false;
349	JobCodes.Active := false;
350	Countries.Active := true;
351	JobCodes.Active := true;
352	JobGradeChangeTimer.Interval := 0;
353	end;
354
355	procedure TForm1.JobGradeDBComboBoxCloseUp(Sender: TObject);
356	begin
357	JobGradeDBComboBox.EditingDone; //See http://bugs.freepascal.org/view.php?id=27186
358	end;
359
360	procedure TForm1.NewDatabaseExecute(Sender: TObject);
361	begin
362	FNoAutoReopen := true;
363	try
364	{Ensure Transaction End}
365	if IBTransaction1.InTransaction then
366	IBTransaction1.Rollback;
367	finally
368	FNoAutoReopen := false;
369	end;
370	IBLocalDBSupport1.NewDatabase;
371	end;
372
373	procedure TForm1.QuitExecute(Sender: TObject);
374	begin
375	Close;
376	end;
377
378	procedure TForm1.RestoreDatabaseExecute(Sender: TObject);
379	begin
380	FNoAutoReopen := true;
381	try
382	{Ensure all changes saved}
383	if IBTransaction1.InTransaction then
384	IBTransaction1.Commit;
385	finally
386	FNoAutoReopen := false;
387	end;
388	IBLocalDBSupport1.RestoreDatabase;
389	end;
390
391	procedure TForm1.SaveDatabaseExecute(Sender: TObject);
392	begin
393	FNoAutoReopen := true;
394	try
395	{Ensure all changes saved}
396	if IBTransaction1.InTransaction then
397	IBTransaction1.Commit;
398	finally
399	FNoAutoReopen := false;
400	end;
401	IBLocalDBSupport1.SaveDatabase;
402	{Start new Transaction and open dataset}
403	ReOpen(0);
404	end;
405
406	procedure TForm1.BeforeDateChange(Sender: TObject);
407	begin
408	Employees.Active := false;
409	Employees.Active := true
410	end;
411
412	procedure TForm1.CancelChangesExecute(Sender: TObject);
413	begin
414	Employees.Transaction.Rollback
415	end;
416
417	procedure TForm1.CountriesBeforeOpen(DataSet: TDataSet);
418	begin
419	Countries.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
420	Countries.ParamByName('JOB_CODE').AsString := EmployeesJOB_CODE.AsString
421	end;
422
423	procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
424	begin
425	if MessageDlg(
426	Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
427	mtConfirmation,[mbYes,mbNo],0) = mrYes then
428	Employees.Delete
429	end;
430
431	procedure TForm1.EditEmployeeExecute(Sender: TObject);
432	begin
433	IBDynamicGrid1.ShowEditorPanel;
434	end;
435
436	procedure TForm1.EditEmployeeUpdate(Sender: TObject);
437	begin
438	(Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
439	end;
440
441	procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
442	begin
443	EmployeesJOB_COUNTRY.AsString := 'USA';
444	EmployeesJOB_CODE.AsString := 'SRep';
445	EmployeesJOB_GRADE.AsInteger := 4;
446	EmployeesSALARY.AsCurrency := 20000;
447	EmployeesFIRST_NAME.AsString := sNoName;
448	EmployeesLAST_NAME.AsString := sNoName;
449	EmployeesHIRE_DATE.AsDateTime := now;
450	EmployeesDEPT_NO.AsString := '000';
451	FDirty := true;
452	end;
453
454	procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
455	begin
456	TotalsQuery.Active := true;
457	IBDynamicGrid1.SetFocus;
458	end;
459
460	procedure TForm1.EmployeesAfterScroll(DataSet: TDataSet);
461	begin
462	JobGradeChangeTimer.Interval := 200;
463	end;
464
465	procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
466	begin
467	TotalsQuery.Active := false
468	end;
469
470	procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
471	begin
472	if BeforeDate.Date > 0 then
473	(DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE < :BeforeDate');
474	if AfterDate.Date > 0 then
475	(DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE > :AfterDate');
476
477	case SalaryRange.ItemIndex of
478	1:
479	(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary < 40000');
480	2:
481	(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 40000 and Salary < 100000');
482	3:
483	(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 100000');
484	end;
485
486
487
488	{Parameter value must be set after all SQL changes have been made}
489	if BeforeDate.Date > 0 then
490	(DataSet as TIBParserDataSet).ParamByName('BeforeDate').AsDateTime := BeforeDate.Date;
491	if AfterDate.Date > 0 then
492	(DataSet as TIBParserDataSet).ParamByName('AfterDate').AsDateTime := AfterDate.Date;
493
494	end;
495
496	procedure TForm1.EmployeesJOB_CODEChange(Sender: TField);
497	begin
498	JobCodeChangeTimer.Interval := 200;
499	end;
500
501	procedure TForm1.EmployeesJOB_GRADEChange(Sender: TField);
502	begin
503	JobGradeChangeTimer.Interval := 200;
504	end;
505
506	procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
507	begin
508	FNoAutoReopen := true;
509	if IBTransaction1.InTransaction then
510	IBTransaction1.Commit;
511	end;
512
513	procedure TForm1.FormShow(Sender: TObject);
514	begin
515	{Set IB Exceptions to only show text message - omit SQLCode and Engine Code}
516	IBDatabase1.FirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);
517	Application.ExceptionDialog := aedOkMessageBox;
518	try
519	IBDatabase1.Connected := true;
520	except On E:Exception do
521	begin
522	MessageDlg(E.Message,mtError,[mbOK],0);
523	Close;
524	Exit
525	end;
526	end;
527
528	{If upgrade failed or downgrade not pending then exit}
529	with IBLocalDBSupport1 do
530	if (CurrentDBVersionNo < RequiredVersionNo) or
531	((CurrentDBVersionNo > RequiredVersionNo) and not DowngradePending) then
532	Close;
533	end;
534
535	procedure TForm1.EmployeesAfterDelete(DataSet: TDataSet);
536	begin
537	FDirty := true
538	end;
539
540	procedure TForm1.EmployeesAfterTransactionEnd(Sender: TObject);
541	begin
542	FDirty := false;
543	if not FNoAutoReopen then
544	Application.QueueAsyncCall(@Reopen,0)
545	end;
546
547	procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
548	var DataAction: TDataAction);
549	begin
550	if E is EIBError then
551	begin
552	MessageDlg(EIBError(E).message,mtError,[mbOK],0);
553	DataSet.Cancel;
554	DataAction := daAbort
555	end;
556	end;
557
558	end.
559