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;

const
  sNoName = '<no name>';

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

{ TForm1 }

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

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

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

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

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

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
  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(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
       DataSet.Cancel;
       DataAction  := daAbort
   end;
end;

end.

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