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