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 DoDBOpen(Data: PtrInt);
    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.DoDBOpen(Data: PtrInt);
begin
  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.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;
  Application.QueueAsyncCall(@DoDBOpen,0);
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:	272
Committed:	Mon Feb 4 13:34:37 2019 UTC (5 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	15342 byte(s)
Log Message:	Fixes merged
#	User	Rev	Content
1	tony	143	(*
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	tony	37	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	tony	272	procedure DoDBOpen(Data: PtrInt);
193	tony	37	procedure Reopen(Data: PtrInt);
194			function GetDBVersionNo: integer;
195			public
196			{ public declarations }
197			property CurrentDBVersion: integer read FCurrentDBVersion;
198			end;
199
200			var
201	tony	209	Form1: TForm1;
202	tony	37
203			implementation
204
205			{$R *.lfm}
206
207	tony	209	uses IB, Unit2, FBMessages;
208	tony	37
209			const
210			sNoName = '<no name>';
211
212			{ TForm1 }
213
214			procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
215			DisplayText: Boolean);
216			begin
217			if DisplayText then
218			begin
219			if Sender.IsNUll then
220			aText := ''
221			else
222			aText := FormatFloat('$#,##0.00',Sender.AsFloat)
223			end
224			else
225			aText := Sender.AsString
226			end;
227
228			procedure TForm1.JobCodesBeforeOpen(DataSet: TDataSet);
229			begin
230			JobCodes.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
231			JobCodes.ParamByName('JOB_COUNTRY').AsString := EmployeesJOB_COUNTRY.AsString
232			end;
233
234			procedure TForm1.SaveChangesExecute(Sender: TObject);
235			begin
236			Employees.Transaction.Commit
237			end;
238
239			procedure TForm1.SaveChangesUpdate(Sender: TObject);
240			begin
241			(Sender as TAction).Enabled := FDirty
242			end;
243
244	tony	272	procedure TForm1.DoDBOpen(Data: PtrInt);
245			begin
246			try
247			IBDatabase1.Connected := true;
248			except On E:Exception do
249			begin
250			MessageDlg(E.Message,mtError,[mbOK],0);
251			Close;
252			Exit
253			end;
254			end;
255
256			{If upgrade failed or downgrade not pending then exit}
257			with IBLocalDBSupport1 do
258			if (CurrentDBVersionNo < RequiredVersionNo) or
259			((CurrentDBVersionNo > RequiredVersionNo) and not DowngradePending) then
260			Close;
261			end;
262
263	tony	37	procedure TForm1.Reopen(Data: PtrInt);
264			begin
265			with IBTransaction1 do
266			if not InTransaction then StartTransaction;
267			Countries.Active := true;
268			Employees.Active := true;
269			JobCodes.Active := true;
270			Depts.Active := true;
271			end;
272
273			function TForm1.GetDBVersionNo: integer;
274			begin
275			FCurrentDBVersion := 0;
276			Result := 0;
277			FNoAutoReopen := true;
278			try
279			with IBTransaction1 do
280			if not InTransaction then StartTransaction;
281			try
282			with CheckVersionTablePresent do
283			begin
284			ExecQuery;
285			try
286			if EOF then Exit;
287			finally
288			Close;
289			end;
290			end;
291
292			with GetDBVersionNoQuery do
293			begin
294			ExecQuery;
295			try
296			Result := FieldByName('VersionNo').AsInteger;
297			FCurrentDBVersion := Result;
298			finally
299			Close;
300			end;
301			end;
302			finally
303			IBTransaction1.Commit;
304			end;
305			finally
306			FNoAutoReopen := false
307			end;
308			end;
309
310
311			procedure TForm1.AddEmployeeExecute(Sender: TObject);
312			begin
313			Employees.Append
314			end;
315
316			procedure TForm1.SelectDeptExecute(Sender: TObject);
317			var Dept_No: string;
318			begin
319			if SelectDeptDlg.ShowModal(EmployeesDEPT_KEY_PATH.AsString,Dept_No) = mrOK then
320			begin
321			Employees.Edit;
322			EmployeesDEPT_NO.AsString := Dept_No;
323			try
324			Employees.Post;
325			except
326			Employees.Cancel;
327			raise;
328			end;
329			IBDynamicGrid1.ShowEditorPanel;
330			end;
331			end;
332
333			procedure TForm1.DBImage1DBImageRead(Sender: TObject; S: TStream;
334			var GraphExt: string);
335			begin
336			GraphExt := 'png';
337			end;
338
339			procedure TForm1.EmployeesValidatePost(Sender: TObject; var CancelPost: boolean
340			);
341			begin
342			{Cancel if no name entered}
343			CancelPost := (EmployeesLAST_NAME.AsString = sNoName) and (EmployeesFIRST_NAME.AsString = sNoName);
344			end;
345
346			procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
347			begin
348			with IBLocalDBSupport1 do
349			if CurrentDBVersionNo = RequiredVersionNo then
350			ReOpen(0);
351			end;
352
353			procedure TForm1.IBLocalDBSupport1GetDBVersionNo(Sender: TObject;
354			var VersionNo: integer);
355			begin
356			VersionNo := GetDBVersionNo;
357			end;
358
359			procedure TForm1.JobCodeChangeTimerTimer(Sender: TObject);
360			begin
361			Countries.Active := false;
362			Countries.Active := true;
363			JobCodeChangeTimer.Interval := 0;
364			end;
365
366			procedure TForm1.JobGradeChangeTimerTimer(Sender: TObject);
367			begin
368			Countries.Active := false;
369			JobCodes.Active := false;
370			Countries.Active := true;
371			JobCodes.Active := true;
372			JobGradeChangeTimer.Interval := 0;
373			end;
374
375			procedure TForm1.JobGradeDBComboBoxCloseUp(Sender: TObject);
376			begin
377			JobGradeDBComboBox.EditingDone; //See http://bugs.freepascal.org/view.php?id=27186
378			end;
379
380			procedure TForm1.NewDatabaseExecute(Sender: TObject);
381			begin
382			FNoAutoReopen := true;
383			try
384			{Ensure Transaction End}
385			if IBTransaction1.InTransaction then
386			IBTransaction1.Rollback;
387			finally
388			FNoAutoReopen := false;
389			end;
390			IBLocalDBSupport1.NewDatabase;
391			end;
392
393			procedure TForm1.QuitExecute(Sender: TObject);
394			begin
395			Close;
396			end;
397
398			procedure TForm1.RestoreDatabaseExecute(Sender: TObject);
399			begin
400			FNoAutoReopen := true;
401			try
402			{Ensure all changes saved}
403			if IBTransaction1.InTransaction then
404			IBTransaction1.Commit;
405			finally
406			FNoAutoReopen := false;
407			end;
408			IBLocalDBSupport1.RestoreDatabase;
409			end;
410
411			procedure TForm1.SaveDatabaseExecute(Sender: TObject);
412			begin
413			FNoAutoReopen := true;
414			try
415			{Ensure all changes saved}
416			if IBTransaction1.InTransaction then
417			IBTransaction1.Commit;
418			finally
419			FNoAutoReopen := false;
420			end;
421			IBLocalDBSupport1.SaveDatabase;
422			{Start new Transaction and open dataset}
423			ReOpen(0);
424			end;
425
426			procedure TForm1.BeforeDateChange(Sender: TObject);
427			begin
428			Employees.Active := false;
429			Employees.Active := true
430			end;
431
432			procedure TForm1.CancelChangesExecute(Sender: TObject);
433			begin
434			Employees.Transaction.Rollback
435			end;
436
437			procedure TForm1.CountriesBeforeOpen(DataSet: TDataSet);
438			begin
439			Countries.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
440			Countries.ParamByName('JOB_CODE').AsString := EmployeesJOB_CODE.AsString
441			end;
442
443			procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
444			begin
445			if MessageDlg(
446			Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
447			mtConfirmation,[mbYes,mbNo],0) = mrYes then
448			Employees.Delete
449			end;
450
451			procedure TForm1.EditEmployeeExecute(Sender: TObject);
452			begin
453			IBDynamicGrid1.ShowEditorPanel;
454			end;
455
456			procedure TForm1.EditEmployeeUpdate(Sender: TObject);
457			begin
458			(Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
459			end;
460
461			procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
462			begin
463			EmployeesJOB_COUNTRY.AsString := 'USA';
464			EmployeesJOB_CODE.AsString := 'SRep';
465			EmployeesJOB_GRADE.AsInteger := 4;
466			EmployeesSALARY.AsCurrency := 20000;
467			EmployeesFIRST_NAME.AsString := sNoName;
468			EmployeesLAST_NAME.AsString := sNoName;
469			EmployeesHIRE_DATE.AsDateTime := now;
470			EmployeesDEPT_NO.AsString := '000';
471			FDirty := true;
472			end;
473
474			procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
475			begin
476			TotalsQuery.Active := true;
477			IBDynamicGrid1.SetFocus;
478			end;
479
480			procedure TForm1.EmployeesAfterScroll(DataSet: TDataSet);
481			begin
482			JobGradeChangeTimer.Interval := 200;
483			end;
484
485			procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
486			begin
487			TotalsQuery.Active := false
488			end;
489
490			procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
491			begin
492			if BeforeDate.Date > 0 then
493			(DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE < :BeforeDate');
494			if AfterDate.Date > 0 then
495			(DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE > :AfterDate');
496
497			case SalaryRange.ItemIndex of
498			1:
499			(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary < 40000');
500			2:
501			(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 40000 and Salary < 100000');
502			3:
503			(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 100000');
504			end;
505
506
507
508			{Parameter value must be set after all SQL changes have been made}
509			if BeforeDate.Date > 0 then
510			(DataSet as TIBParserDataSet).ParamByName('BeforeDate').AsDateTime := BeforeDate.Date;
511			if AfterDate.Date > 0 then
512			(DataSet as TIBParserDataSet).ParamByName('AfterDate').AsDateTime := AfterDate.Date;
513
514			end;
515
516			procedure TForm1.EmployeesJOB_CODEChange(Sender: TField);
517			begin
518			JobCodeChangeTimer.Interval := 200;
519			end;
520
521			procedure TForm1.EmployeesJOB_GRADEChange(Sender: TField);
522			begin
523			JobGradeChangeTimer.Interval := 200;
524			end;
525
526			procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
527			begin
528			FNoAutoReopen := true;
529			if IBTransaction1.InTransaction then
530			IBTransaction1.Commit;
531			end;
532
533			procedure TForm1.FormShow(Sender: TObject);
534			begin
535	tony	209	{Set IB Exceptions to only show text message - omit SQLCode and Engine Code}
536	tony	263	IBDatabase1.FirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);
537	tony	209	Application.ExceptionDialog := aedOkMessageBox;
538	tony	272	Application.QueueAsyncCall(@DoDBOpen,0);
539	tony	37	end;
540
541			procedure TForm1.EmployeesAfterDelete(DataSet: TDataSet);
542			begin
543			FDirty := true
544			end;
545
546			procedure TForm1.EmployeesAfterTransactionEnd(Sender: TObject);
547			begin
548			FDirty := false;
549			if not FNoAutoReopen then
550			Application.QueueAsyncCall(@Reopen,0)
551			end;
552
553			procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
554			var DataAction: TDataAction);
555			begin
556			if E is EIBError then
557			begin
558	tony	209	MessageDlg(EIBError(E).message,mtError,[mbOK],0);
559	tony	37	DataSet.Cancel;
560			DataAction := daAbort
561			end;
562			end;
563
564			end.
565