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
#	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			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	tony	209	Form1: TForm1;
201	tony	37
202			implementation
203
204			{$R *.lfm}
205
206	tony	209	uses IB, Unit2, FBMessages;
207	tony	37
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	tony	209	{Set IB Exceptions to only show text message - omit SQLCode and Engine Code}
516	tony	263	IBDatabase1.FirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);
517	tony	209	Application.ExceptionDialog := aedOkMessageBox;
518	tony	37	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	tony	209	MessageDlg(EIBError(E).message,mtError,[mbOK],0);
553	tony	37	DataSet.Cancel;
554			DataAction := daAbort
555			end;
556			end;
557
558			end.
559