examples/local-employeedb/unit1.pas

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:	107
Committed:	Thu Jan 18 14:37:40 2018 UTC (6 years, 3 months ago) by tony
Content type:	text/x-pascal
File size:	14451 byte(s)
Log Message:	Fixes merged
#	User	Rev	Content
1	tony	37	unit Unit1;
2
3			{$mode objfpc}{$H+}
4
5			interface
6
7			uses
8			Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, DBGrids,
9			StdCtrls, ActnList, EditBtn, DbCtrls, ExtCtrls, Buttons, IBDatabase, IBQuery,
10			IBCustomDataSet, IBSQL, IBDynamicGrid, IBLookupComboEditBox,
11			IBLocalDBSupport, db, DBExtCtrls, Menus;
12
13			const
14			RequiredVersionNo = 2;
15
16			type
17
18			{ TForm1 }
19
20			TForm1 = class(TForm)
21			CheckVersionTablePresent: TIBSQL;
22			DBImage1: TDBImage;
23			EmployeesPHOTO1: TBlobField;
24			GetDBVersionNoQuery: TIBSQL;
25			MenuItem6: TMenuItem;
26			MenuItem7: TMenuItem;
27			Panel3: TPanel;
28			Quit: TAction;
29			MainMenu1: TMainMenu;
30			MenuItem1: TMenuItem;
31			MenuItem2: TMenuItem;
32			MenuItem3: TMenuItem;
33			MenuItem4: TMenuItem;
34			MenuItem5: TMenuItem;
35			RestoreDatabase: TAction;
36			SaveDatabase: TAction;
37			NewDatabase: TAction;
38			DBEdit6: TDBEdit;
39			EmployeesDEPT_KEY_PATH: TIBStringField;
40			EmployeesDEPT_PATH: TIBStringField;
41			IBLocalDBSupport1: TIBLocalDBSupport;
42			IBLookupComboEditBox1: TIBLookupComboEditBox;
43			IBLookupComboEditBox2: TIBLookupComboEditBox;
44			IBQuery1DEPT_NO: TIBStringField;
45			IBQuery1EMP_NO: TSmallintField;
46			IBQuery1FIRST_NAME: TIBStringField;
47			IBQuery1FULL_NAME: TIBStringField;
48			IBQuery1HIRE_DATE: TDateTimeField;
49			IBQuery1JOB_CODE: TIBStringField;
50			IBQuery1JOB_COUNTRY: TIBStringField;
51			IBQuery1JOB_GRADE: TSmallintField;
52			IBQuery1LAST_NAME: TIBStringField;
53			IBQuery1PHONE_EXT: TIBStringField;
54			IBQuery1SALARY: TIBBCDField;
55			SelectDept: TAction;
56			Button4: TButton;
57			Button5: TButton;
58			CancelChanges: TAction;
59			SalaryRange: TComboBox;
60			CountrySource: TDataSource;
61			BeforeDate: TDateEdit;
62			AfterDate: TDateEdit;
63			DeptsSource: TDataSource;
64			Depts: TIBQuery;
65			JobCodeSource: TDataSource;
66			DBEdit1: TDBEdit;
67			DBEdit2: TDBEdit;
68			DBEdit3: TDBEdit;
69			DBEdit4: TDBEdit;
70			DBEdit5: TDBEdit;
71			DBText1: TDBText;
72			Employees: TIBDataSet;
73			EmployeesDEPT_NO: TIBStringField;
74			EmployeesEMP_NO: TSmallintField;
75			EmployeesFIRST_NAME: TIBStringField;
76			EmployeesFULL_NAME: TIBStringField;
77			EmployeesHIRE_DATE: TDateTimeField;
78			EmployeesJOB_CODE: TIBStringField;
79			EmployeesJOB_COUNTRY: TIBStringField;
80			EmployeesJOB_GRADE: TSmallintField;
81			EmployeesLAST_NAME: TIBStringField;
82			EmployeesPHONE_EXT: TIBStringField;
83			EmployeesSALARY: TIBBCDField;
84			IBDateEdit1: TDBDateEdit;
85			IBDynamicGrid1: TIBDynamicGrid;
86			Countries: TIBQuery;
87			JobCodes: TIBQuery;
88			JobGradeDBComboBox: TDBComboBox;
89			Label10: TLabel;
90			Label11: TLabel;
91			Label12: TLabel;
92			Label13: TLabel;
93			Label3: TLabel;
94			Label4: TLabel;
95			Label5: TLabel;
96			Label6: TLabel;
97			Label7: TLabel;
98			Label8: TLabel;
99			Label9: TLabel;
100			Panel1: TPanel;
101			Panel2: TPanel;
102			EmployeeEditorPanel: TPanel;
103			SpeedButton1: TSpeedButton;
104			JobGradeChangeTimer: TTimer;
105			JobCodeChangeTimer: TTimer;
106			TotalsQueryTOTALSALARIES: TIBBCDField;
107			TotalsSource: TDataSource;
108			TotalsQuery: TIBQuery;
109			Label1: TLabel;
110			Label2: TLabel;
111			SaveChanges: TAction;
112			DeleteEmployee: TAction;
113			EditEmployee: TAction;
114			AddEmployee: TAction;
115			ActionList1: TActionList;
116			Button1: TButton;
117			Button2: TButton;
118			Button3: TButton;
119			EmployeeSource: TDataSource;
120			IBDatabase1: TIBDatabase;
121			IBTransaction1: TIBTransaction;
122			procedure DBImage1DBImageRead(Sender: TObject; S: TStream;
123			var GraphExt: string);
124			procedure EmployeesValidatePost(Sender: TObject; var CancelPost: boolean);
125			procedure IBDatabase1AfterConnect(Sender: TObject);
126			procedure IBLocalDBSupport1GetDBVersionNo(Sender: TObject;
127			var VersionNo: integer);
128			procedure JobCodeChangeTimerTimer(Sender: TObject);
129			procedure JobGradeChangeTimerTimer(Sender: TObject);
130			procedure JobGradeDBComboBoxCloseUp(Sender: TObject);
131			procedure NewDatabaseExecute(Sender: TObject);
132			procedure QuitExecute(Sender: TObject);
133			procedure RestoreDatabaseExecute(Sender: TObject);
134			procedure SaveDatabaseExecute(Sender: TObject);
135			procedure SelectDeptExecute(Sender: TObject);
136			procedure AddEmployeeExecute(Sender: TObject);
137			procedure BeforeDateChange(Sender: TObject);
138			procedure CancelChangesExecute(Sender: TObject);
139			procedure CountriesBeforeOpen(DataSet: TDataSet);
140			procedure DeleteEmployeeExecute(Sender: TObject);
141			procedure EditEmployeeExecute(Sender: TObject);
142			procedure EditEmployeeUpdate(Sender: TObject);
143			procedure EmployeesAfterInsert(DataSet: TDataSet);
144			procedure EmployeesAfterOpen(DataSet: TDataSet);
145			procedure EmployeesAfterScroll(DataSet: TDataSet);
146			procedure EmployeesBeforeClose(DataSet: TDataSet);
147			procedure EmployeesBeforeOpen(DataSet: TDataSet);
148			procedure EmployeesJOB_CODEChange(Sender: TField);
149			procedure EmployeesJOB_GRADEChange(Sender: TField);
150			procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
151			procedure FormShow(Sender: TObject);
152			procedure EmployeesAfterDelete(DataSet: TDataSet);
153			procedure EmployeesAfterTransactionEnd(Sender: TObject);
154			procedure EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
155			var DataAction: TDataAction);
156			procedure EmployeesSALARYGetText(Sender: TField; var aText: string;
157			DisplayText: Boolean);
158			procedure JobCodesBeforeOpen(DataSet: TDataSet);
159			procedure SaveChangesExecute(Sender: TObject);
160			procedure SaveChangesUpdate(Sender: TObject);
161			private
162			FCurrentDBVersion: integer;
163			{ private declarations }
164			FDirty: boolean;
165			FNoAutoReopen: boolean;
166			procedure Reopen(Data: PtrInt);
167			function GetDBVersionNo: integer;
168			public
169			{ public declarations }
170			property CurrentDBVersion: integer read FCurrentDBVersion;
171			end;
172
173			var
174			Form1: TForm1;
175
176			implementation
177
178			{$R *.lfm}
179
180			uses IB, Unit2;
181
182			const
183			sNoName = '<no name>';
184
185			function ExtractDBException(msg: string): string;
186			var Lines: TStringList;
187			begin
188			Lines := TStringList.Create;
189			try
190			Lines.Text := msg;
191			if pos('exception',Lines[0]) = 1 then
192			Result := Lines[2]
193			else
194			Result := msg
195			finally
196			Lines.Free
197			end;
198			end;
199
200			{ TForm1 }
201
202			procedure TForm1.EmployeesSALARYGetText(Sender: TField; var aText: string;
203			DisplayText: Boolean);
204			begin
205			if DisplayText then
206			begin
207			if Sender.IsNUll then
208			aText := ''
209			else
210			aText := FormatFloat('$#,##0.00',Sender.AsFloat)
211			end
212			else
213			aText := Sender.AsString
214			end;
215
216			procedure TForm1.JobCodesBeforeOpen(DataSet: TDataSet);
217			begin
218			JobCodes.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
219			JobCodes.ParamByName('JOB_COUNTRY').AsString := EmployeesJOB_COUNTRY.AsString
220			end;
221
222			procedure TForm1.SaveChangesExecute(Sender: TObject);
223			begin
224			Employees.Transaction.Commit
225			end;
226
227			procedure TForm1.SaveChangesUpdate(Sender: TObject);
228			begin
229			(Sender as TAction).Enabled := FDirty
230			end;
231
232			procedure TForm1.Reopen(Data: PtrInt);
233			begin
234			with IBTransaction1 do
235			if not InTransaction then StartTransaction;
236			Countries.Active := true;
237			Employees.Active := true;
238			JobCodes.Active := true;
239			Depts.Active := true;
240			end;
241
242			function TForm1.GetDBVersionNo: integer;
243			begin
244			FCurrentDBVersion := 0;
245			Result := 0;
246			FNoAutoReopen := true;
247			try
248			with IBTransaction1 do
249			if not InTransaction then StartTransaction;
250			try
251			with CheckVersionTablePresent do
252			begin
253			ExecQuery;
254			try
255			if EOF then Exit;
256			finally
257			Close;
258			end;
259			end;
260
261			with GetDBVersionNoQuery do
262			begin
263			ExecQuery;
264			try
265			Result := FieldByName('VersionNo').AsInteger;
266			FCurrentDBVersion := Result;
267			finally
268			Close;
269			end;
270			end;
271			finally
272			IBTransaction1.Commit;
273			end;
274			finally
275			FNoAutoReopen := false
276			end;
277			end;
278
279
280			procedure TForm1.AddEmployeeExecute(Sender: TObject);
281			begin
282			Employees.Append
283			end;
284
285			procedure TForm1.SelectDeptExecute(Sender: TObject);
286			var Dept_No: string;
287			begin
288			if SelectDeptDlg.ShowModal(EmployeesDEPT_KEY_PATH.AsString,Dept_No) = mrOK then
289			begin
290			Employees.Edit;
291			EmployeesDEPT_NO.AsString := Dept_No;
292			try
293			Employees.Post;
294			except
295			Employees.Cancel;
296			raise;
297			end;
298			IBDynamicGrid1.ShowEditorPanel;
299			end;
300			end;
301
302			procedure TForm1.DBImage1DBImageRead(Sender: TObject; S: TStream;
303			var GraphExt: string);
304			begin
305			GraphExt := 'png';
306			end;
307
308			procedure TForm1.EmployeesValidatePost(Sender: TObject; var CancelPost: boolean
309			);
310			begin
311			{Cancel if no name entered}
312			CancelPost := (EmployeesLAST_NAME.AsString = sNoName) and (EmployeesFIRST_NAME.AsString = sNoName);
313			end;
314
315			procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
316			begin
317			with IBLocalDBSupport1 do
318			if CurrentDBVersionNo = RequiredVersionNo then
319			ReOpen(0);
320			end;
321
322			procedure TForm1.IBLocalDBSupport1GetDBVersionNo(Sender: TObject;
323			var VersionNo: integer);
324			begin
325			VersionNo := GetDBVersionNo;
326			end;
327
328			procedure TForm1.JobCodeChangeTimerTimer(Sender: TObject);
329			begin
330			Countries.Active := false;
331			Countries.Active := true;
332			JobCodeChangeTimer.Interval := 0;
333			end;
334
335			procedure TForm1.JobGradeChangeTimerTimer(Sender: TObject);
336			begin
337			Countries.Active := false;
338			JobCodes.Active := false;
339			Countries.Active := true;
340			JobCodes.Active := true;
341			JobGradeChangeTimer.Interval := 0;
342			end;
343
344			procedure TForm1.JobGradeDBComboBoxCloseUp(Sender: TObject);
345			begin
346			JobGradeDBComboBox.EditingDone; //See http://bugs.freepascal.org/view.php?id=27186
347			end;
348
349			procedure TForm1.NewDatabaseExecute(Sender: TObject);
350			begin
351			FNoAutoReopen := true;
352			try
353			{Ensure Transaction End}
354			if IBTransaction1.InTransaction then
355			IBTransaction1.Rollback;
356			finally
357			FNoAutoReopen := false;
358			end;
359			IBLocalDBSupport1.NewDatabase;
360			end;
361
362			procedure TForm1.QuitExecute(Sender: TObject);
363			begin
364			Close;
365			end;
366
367			procedure TForm1.RestoreDatabaseExecute(Sender: TObject);
368			begin
369			FNoAutoReopen := true;
370			try
371			{Ensure all changes saved}
372			if IBTransaction1.InTransaction then
373			IBTransaction1.Commit;
374			finally
375			FNoAutoReopen := false;
376			end;
377			IBLocalDBSupport1.RestoreDatabase;
378			end;
379
380			procedure TForm1.SaveDatabaseExecute(Sender: TObject);
381			begin
382			FNoAutoReopen := true;
383			try
384			{Ensure all changes saved}
385			if IBTransaction1.InTransaction then
386			IBTransaction1.Commit;
387			finally
388			FNoAutoReopen := false;
389			end;
390			IBLocalDBSupport1.SaveDatabase;
391			{Start new Transaction and open dataset}
392			ReOpen(0);
393			end;
394
395			procedure TForm1.BeforeDateChange(Sender: TObject);
396			begin
397			Employees.Active := false;
398			Employees.Active := true
399			end;
400
401			procedure TForm1.CancelChangesExecute(Sender: TObject);
402			begin
403			Employees.Transaction.Rollback
404			end;
405
406			procedure TForm1.CountriesBeforeOpen(DataSet: TDataSet);
407			begin
408			Countries.ParamByName('JOB_GRADE').AsInteger := EmployeesJOB_GRADE.AsInteger;
409			Countries.ParamByName('JOB_CODE').AsString := EmployeesJOB_CODE.AsString
410			end;
411
412			procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
413			begin
414			if MessageDlg(
415			Format('Remove %s from Employee List?',[Employees.FieldByName('Full_Name').AsString]),
416			mtConfirmation,[mbYes,mbNo],0) = mrYes then
417			Employees.Delete
418			end;
419
420			procedure TForm1.EditEmployeeExecute(Sender: TObject);
421			begin
422			IBDynamicGrid1.ShowEditorPanel;
423			end;
424
425			procedure TForm1.EditEmployeeUpdate(Sender: TObject);
426			begin
427			(Sender as TAction).Enabled := Employees.Active and (Employees.RecordCount > 0)
428			end;
429
430			procedure TForm1.EmployeesAfterInsert(DataSet: TDataSet);
431			begin
432			EmployeesJOB_COUNTRY.AsString := 'USA';
433			EmployeesJOB_CODE.AsString := 'SRep';
434			EmployeesJOB_GRADE.AsInteger := 4;
435			EmployeesSALARY.AsCurrency := 20000;
436			EmployeesFIRST_NAME.AsString := sNoName;
437			EmployeesLAST_NAME.AsString := sNoName;
438			EmployeesHIRE_DATE.AsDateTime := now;
439			EmployeesDEPT_NO.AsString := '000';
440			FDirty := true;
441			end;
442
443			procedure TForm1.EmployeesAfterOpen(DataSet: TDataSet);
444			begin
445			TotalsQuery.Active := true;
446			IBDynamicGrid1.SetFocus;
447			end;
448
449			procedure TForm1.EmployeesAfterScroll(DataSet: TDataSet);
450			begin
451			JobGradeChangeTimer.Interval := 200;
452			end;
453
454			procedure TForm1.EmployeesBeforeClose(DataSet: TDataSet);
455			begin
456			TotalsQuery.Active := false
457			end;
458
459			procedure TForm1.EmployeesBeforeOpen(DataSet: TDataSet);
460			begin
461			if BeforeDate.Date > 0 then
462			(DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE < :BeforeDate');
463			if AfterDate.Date > 0 then
464			(DataSet as TIBParserDataSet).Parser.Add2WhereClause('HIRE_DATE > :AfterDate');
465
466			case SalaryRange.ItemIndex of
467			1:
468			(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary < 40000');
469			2:
470			(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 40000 and Salary < 100000');
471			3:
472			(DataSet as TIBParserDataSet).Parser.Add2WhereClause('Salary >= 100000');
473			end;
474
475
476
477			{Parameter value must be set after all SQL changes have been made}
478			if BeforeDate.Date > 0 then
479			(DataSet as TIBParserDataSet).ParamByName('BeforeDate').AsDateTime := BeforeDate.Date;
480			if AfterDate.Date > 0 then
481			(DataSet as TIBParserDataSet).ParamByName('AfterDate').AsDateTime := AfterDate.Date;
482
483			end;
484
485			procedure TForm1.EmployeesJOB_CODEChange(Sender: TField);
486			begin
487			JobCodeChangeTimer.Interval := 200;
488			end;
489
490			procedure TForm1.EmployeesJOB_GRADEChange(Sender: TField);
491			begin
492			JobGradeChangeTimer.Interval := 200;
493			end;
494
495			procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
496			begin
497			FNoAutoReopen := true;
498			if IBTransaction1.InTransaction then
499			IBTransaction1.Commit;
500			end;
501
502			procedure TForm1.FormShow(Sender: TObject);
503			begin
504			try
505			IBDatabase1.Connected := true;
506			except On E:Exception do
507			begin
508			MessageDlg(E.Message,mtError,[mbOK],0);
509			Close;
510			Exit
511			end;
512			end;
513
514			{If upgrade failed or downgrade not pending then exit}
515			with IBLocalDBSupport1 do
516			if (CurrentDBVersionNo < RequiredVersionNo) or
517			((CurrentDBVersionNo > RequiredVersionNo) and not DowngradePending) then
518			Close;
519			end;
520
521			procedure TForm1.EmployeesAfterDelete(DataSet: TDataSet);
522			begin
523			FDirty := true
524			end;
525
526			procedure TForm1.EmployeesAfterTransactionEnd(Sender: TObject);
527			begin
528			FDirty := false;
529			if not FNoAutoReopen then
530			Application.QueueAsyncCall(@Reopen,0)
531			end;
532
533			procedure TForm1.EmployeesPostError(DataSet: TDataSet; E: EDatabaseError;
534			var DataAction: TDataAction);
535			begin
536			if E is EIBError then
537			begin
538			MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
539			DataSet.Cancel;
540			DataAction := daAbort
541			end;
542			end;
543
544			end.
545