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