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