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, IBMessages;

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;
  Employees.Active := true;
  Countries.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:	410
Committed:	Thu Jun 22 13:52:39 2023 UTC (17 months ago) by tony
Content type:	text/x-pascal
File size:	15342 byte(s)
Log Message:	Release 2.6.0 beta
#	Content
1	(*
2	* IBX For Lazarus (Firebird Express)
3	*
4	* The contents of this file are subject to the Initial Developer's
5	* Public License Version 1.0 (the "License"); you may not use this
6	* file except in compliance with the License. You may obtain a copy
7	* of the License here:
8	*
9	* http://www.firebirdsql.org/index.php?op=doc&id=idpl
10	*
11	* Software distributed under the License is distributed on an "AS
12	* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13	* implied. See the License for the specific language governing rights
14	* and limitations under the License.
15	*
16	* The Initial Developer of the Original Code is Tony Whyman.
17	*
18	* The Original Code is (C) 2015 Tony Whyman, MWA Software
19	* (http://www.mwasoftware.co.uk).
20	*
21	* All Rights Reserved.
22	*
23	* Contributor(s): ______________________________________.
24	*
25	*)
26
27	unit Unit1;
28
29	{$mode objfpc}{$H+}
30
31	interface
32
33	uses
34	Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, DBGrids,
35	StdCtrls, ActnList, EditBtn, DbCtrls, ExtCtrls, Buttons, IBDatabase, IBQuery,
36	IBCustomDataSet, IBSQL, IBDynamicGrid, IBLookupComboEditBox,
37	IBLocalDBSupport, db, DBExtCtrls, Menus;
38
39	const
40	RequiredVersionNo = 2;
41
42	type
43
44	{ TForm1 }
45
46	TForm1 = class(TForm)
47	CheckVersionTablePresent: TIBSQL;
48	DBImage1: TDBImage;
49	EmployeesPHOTO1: TBlobField;
50	GetDBVersionNoQuery: TIBSQL;
51	MenuItem6: TMenuItem;
52	MenuItem7: TMenuItem;
53	Panel3: TPanel;
54	Quit: TAction;
55	MainMenu1: TMainMenu;
56	MenuItem1: TMenuItem;
57	MenuItem2: TMenuItem;
58	MenuItem3: TMenuItem;
59	MenuItem4: TMenuItem;
60	MenuItem5: TMenuItem;
61	RestoreDatabase: TAction;
62	SaveDatabase: TAction;
63	NewDatabase: TAction;
64	DBEdit6: TDBEdit;
65	EmployeesDEPT_KEY_PATH: TIBStringField;
66	EmployeesDEPT_PATH: TIBStringField;
67	IBLocalDBSupport1: TIBLocalDBSupport;
68	IBLookupComboEditBox1: TIBLookupComboEditBox;
69	IBLookupComboEditBox2: TIBLookupComboEditBox;
70	IBQuery1DEPT_NO: TIBStringField;
71	IBQuery1EMP_NO: TSmallintField;
72	IBQuery1FIRST_NAME: TIBStringField;
73	IBQuery1FULL_NAME: TIBStringField;
74	IBQuery1HIRE_DATE: TDateTimeField;
75	IBQuery1JOB_CODE: TIBStringField;
76	IBQuery1JOB_COUNTRY: TIBStringField;
77	IBQuery1JOB_GRADE: TSmallintField;
78	IBQuery1LAST_NAME: TIBStringField;
79	IBQuery1PHONE_EXT: TIBStringField;
80	IBQuery1SALARY: TIBBCDField;
81	SelectDept: TAction;
82	Button4: TButton;
83	Button5: TButton;
84	CancelChanges: TAction;
85	SalaryRange: TComboBox;
86	CountrySource: TDataSource;
87	BeforeDate: TDateEdit;
88	AfterDate: TDateEdit;
89	DeptsSource: TDataSource;
90	Depts: TIBQuery;
91	JobCodeSource: TDataSource;
92	DBEdit1: TDBEdit;
93	DBEdit2: TDBEdit;
94	DBEdit3: TDBEdit;
95	DBEdit4: TDBEdit;
96	DBEdit5: TDBEdit;
97	DBText1: TDBText;
98	Employees: TIBDataSet;
99	EmployeesDEPT_NO: TIBStringField;
100	EmployeesEMP_NO: TSmallintField;
101	EmployeesFIRST_NAME: TIBStringField;
102	EmployeesFULL_NAME: TIBStringField;
103	EmployeesHIRE_DATE: TDateTimeField;
104	EmployeesJOB_CODE: TIBStringField;
105	EmployeesJOB_COUNTRY: TIBStringField;
106	EmployeesJOB_GRADE: TSmallintField;
107	EmployeesLAST_NAME: TIBStringField;
108	EmployeesPHONE_EXT: TIBStringField;
109	EmployeesSALARY: TIBBCDField;
110	IBDateEdit1: TDBDateEdit;
111	IBDynamicGrid1: TIBDynamicGrid;
112	Countries: TIBQuery;
113	JobCodes: TIBQuery;
114	JobGradeDBComboBox: TDBComboBox;
115	Label10: TLabel;
116	Label11: TLabel;
117	Label12: TLabel;
118	Label13: TLabel;
119	Label3: TLabel;
120	Label4: TLabel;
121	Label5: TLabel;
122	Label6: TLabel;
123	Label7: TLabel;
124	Label8: TLabel;
125	Label9: TLabel;
126	Panel1: TPanel;
127	Panel2: TPanel;
128	EmployeeEditorPanel: TPanel;
129	SpeedButton1: TSpeedButton;
130	JobGradeChangeTimer: TTimer;
131	JobCodeChangeTimer: TTimer;
132	TotalsQueryTOTALSALARIES: TIBBCDField;
133	TotalsSource: TDataSource;
134	TotalsQuery: TIBQuery;
135	Label1: TLabel;
136	Label2: TLabel;
137	SaveChanges: TAction;
138	DeleteEmployee: TAction;
139	EditEmployee: TAction;
140	AddEmployee: TAction;
141	ActionList1: TActionList;
142	Button1: TButton;
143	Button2: TButton;
144	Button3: TButton;
145	EmployeeSource: TDataSource;
146	IBDatabase1: TIBDatabase;
147	IBTransaction1: TIBTransaction;
148	procedure DBImage1DBImageRead(Sender: TObject; S: TStream;
149	var GraphExt: string);
150	procedure EmployeesValidatePost(Sender: TObject; var CancelPost: boolean);
151	procedure IBDatabase1AfterConnect(Sender: TObject);
152	procedure IBLocalDBSupport1GetDBVersionNo(Sender: TObject;
153	var VersionNo: integer);
154	procedure JobCodeChangeTimerTimer(Sender: TObject);
155	procedure JobGradeChangeTimerTimer(Sender: TObject);
156	procedure JobGradeDBComboBoxCloseUp(Sender: TObject);
157	procedure NewDatabaseExecute(Sender: TObject);
158	procedure QuitExecute(Sender: TObject);
159	procedure RestoreDatabaseExecute(Sender: TObject);
160	procedure SaveDatabaseExecute(Sender: TObject);
161	procedure SelectDeptExecute(Sender: TObject);
162	procedure AddEmployeeExecute(Sender: TObject);
163	procedure BeforeDateChange(Sender: TObject);
164	procedure CancelChangesExecute(Sender: TObject);
165	procedure CountriesBeforeOpen(DataSet: TDataSet);
166	procedure DeleteEmployeeExecute(Sender: TObject);
167	procedure EditEmployeeExecute(Sender: TObject);
168	procedure EditEmployeeUpdate(Sender: TObject);
169	procedure EmployeesAfterInsert(DataSet: TDataSet);
170	procedure EmployeesAfterOpen(DataSet: TDataSet);
171	procedure EmployeesAfterScroll(DataSet: TDataSet);
172	procedure EmployeesBeforeClose(DataSet: TDataSet);
173	procedure EmployeesBeforeOpen(DataSet: TDataSet);
174	procedure EmployeesJOB_CODEChange(Sender: TField);
175	procedure EmployeesJOB_GRADEChange(Sender: TField);
176	procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
177	procedure FormShow(Sender: TObject);
178	procedure EmployeesAfterDelete(DataSet: TDataSet);
179	procedure EmployeesAfterTransactionEnd(Sender: TObject);
180	procedure EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
181	var DataAction: TDataAction);
182	procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
183	DisplayText: Boolean);
184	procedure JobCodesBeforeOpen(DataSet: TDataSet);
185	procedure SaveChangesExecute(Sender: TObject);
186	procedure SaveChangesUpdate(Sender: TObject);
187	private
188	FCurrentDBVersion: integer;
189	{ private declarations }
190	FDirty: boolean;
191	FNoAutoReopen: boolean;
192	procedure DoDBOpen(Data: PtrInt);
193	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	Form1: TForm1;
202
203	implementation
204
205	{$R *.lfm}
206
207	uses IB, Unit2, IBMessages;
208
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	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	procedure TForm1.Reopen(Data: PtrInt);
264	begin
265	with IBTransaction1 do
266	if not InTransaction then StartTransaction;
267	Employees.Active := true;
268	Countries.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	{Set IB Exceptions to only show text message - omit SQLCode and Engine Code}
536	IBDatabase1.FirebirdAPI.GetStatus.SetIBDataBaseErrorMessages([ShowIBMessage]);
537	Application.ExceptionDialog := aedOkMessageBox;
538	Application.QueueAsyncCall(@DoDBOpen,0);
539	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	MessageDlg(EIBError(E).message,mtError,[mbOK],0);
559	DataSet.Cancel;
560	DataAction := daAbort
561	end;
562	end;
563
564	end.
565