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
#	Content
1	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