examples/employee/unit1.pas

unit Unit1; 

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, DBGrids,
  StdCtrls, ActnList, IBDatabase, IBQuery, IBCustomDataSet, IBUpdateSQL, db;

type

  { TForm1 }

  TForm1 = class(TForm)
    CancelChanges: TAction;
    IBQuery1SALARY: TIBBCDField;
    IBUpdateSQL1: TIBUpdateSQL;
    SaveChanges: TAction;
    DeleteEmployee: TAction;
    EditEmployee: TAction;
    AddEmployee: TAction;
    ActionList1: TActionList;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    Datasource1: TDatasource;
    DBGrid1: TDBGrid;
    IBDatabase1: TIBDatabase;
    IBQuery1: TIBQuery;
    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;
    IBTransaction1: TIBTransaction;
    procedure AddEmployeeExecute(Sender: TObject);
    procedure CancelChangesExecute(Sender: TObject);
    procedure DBGrid1DblClick(Sender: TObject);
    procedure DeleteEmployeeExecute(Sender: TObject);
    procedure EditEmployeeExecute(Sender: TObject);
    procedure EditEmployeeUpdate(Sender: TObject);
    procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure IBDatabase1AfterConnect(Sender: TObject);
    procedure IBDatabase1BeforeDisconnect(Sender: TObject);
    procedure IBQuery1AfterDelete(DataSet: TDataSet);
    procedure IBQuery1AfterOpen(DataSet: TDataSet);
    procedure IBQuery1AfterTransactionEnd(Sender: TObject);
    procedure IBQuery1BeforeClose(DataSet: TDataSet);
    procedure IBQuery1PostError(DataSet: TDataSet; E: EDatabaseError;
      var DataAction: TDataAction);
    procedure IBQuery1SALARYGetText(Sender: TField; var aText: string;
      DisplayText: Boolean);
    procedure SaveChangesExecute(Sender: TObject);
    procedure SaveChangesUpdate(Sender: TObject);
  private
    { private declarations }
    FDirty: boolean;
    FClosing: boolean;
    FLastEmp_no: integer;
    procedure Reopen(Data: PtrInt);
  public
    { public declarations }
  end; 

var
  Form1: TForm1; 

implementation

{$R *.lfm}

uses Unit2, Unit3, IB;

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.IBQuery1SALARYGetText(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.SaveChangesExecute(Sender: TObject);
begin
  IBQuery1.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;
  IBQuery1.Active := true
end;

procedure TForm1.AddEmployeeExecute(Sender: TObject);
var NewEmpNo: integer;
begin
  if AddEmployeeDlg.ShowModal(NewEmpNo) = mrOK then
  begin
    FDirty := true;
    IBQuery1.Active := false;
    FLastEmp_no := NewEmpNo;
    IBQuery1.Active := true
  end;
end;

procedure TForm1.CancelChangesExecute(Sender: TObject);
begin
  IBQuery1.Transaction.Rollback
end;

procedure TForm1.DBGrid1DblClick(Sender: TObject);
begin
  if IBQuery1.Active and (IBQuery1.RecordCount > 0) then
    EditEmployeeExecute(nil)
end;

procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
begin
  if MessageDlg(
    Format('Remove %s from Employee List?',[IBQuery1.FieldByName('Full_Name').AsString]),
    mtConfirmation,[mbYes,mbNo],0) = mrYes then
    IBQuery1.Delete
end;

procedure TForm1.EditEmployeeExecute(Sender: TObject);
begin
  if EditEmployeeDlg.ShowModal(IBQuery1.FieldByName('Emp_No').AsInteger) = mrOK then
  begin
    FDirty := true;
    IBQuery1.Refresh
  end;
end;

procedure TForm1.EditEmployeeUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := IBQuery1.Active and (IBQuery1.RecordCount > 0)
end;

procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
  FClosing := true
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  FLastEmp_no := -1;
  IBQuery1.Active := true
end;

procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
begin
  with IBTransaction1 do
    if not InTransaction then StartTransaction
end;

procedure TForm1.IBDatabase1BeforeDisconnect(Sender: TObject);
begin
  FClosing := true
end;

procedure TForm1.IBQuery1AfterDelete(DataSet: TDataSet);
begin
  FDirty := true
end;

procedure TForm1.IBQuery1AfterOpen(DataSet: TDataSet);
begin
  if FLastEmp_no <> -1 then
    DataSet.Locate('EMP_NO',FLastEmp_no,[])
end;

procedure TForm1.IBQuery1AfterTransactionEnd(Sender: TObject);
begin
  FDirty := false;
  if not FClosing then
    Application.QueueAsyncCall(@Reopen,0)
end;

procedure TForm1.IBQuery1BeforeClose(DataSet: TDataSet);
begin
  FLastEmp_no := DataSet.FieldByName('Emp_no').AsInteger
end;

procedure TForm1.IBQuery1PostError(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:	19
Committed:	Mon Jul 7 13:00:15 2014 UTC (9 years, 9 months ago) by tony
Content type:	text/x-pascal
File size:	6003 byte(s)
Log Message:	Committing updates for Release R1-1-0
#	User	Rev	Content
1	tony	17	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, IBDatabase, IBQuery, IBCustomDataSet, IBUpdateSQL, db;
10
11			type
12
13			{ TForm1 }
14
15			TForm1 = class(TForm)
16			CancelChanges: TAction;
17	tony	19	IBQuery1SALARY: TIBBCDField;
18	tony	17	IBUpdateSQL1: TIBUpdateSQL;
19			SaveChanges: TAction;
20			DeleteEmployee: TAction;
21			EditEmployee: TAction;
22			AddEmployee: TAction;
23			ActionList1: TActionList;
24			Button1: TButton;
25			Button2: TButton;
26			Button3: TButton;
27			Button4: TButton;
28			Button5: TButton;
29			Datasource1: TDatasource;
30			DBGrid1: TDBGrid;
31			IBDatabase1: TIBDatabase;
32			IBQuery1: TIBQuery;
33			IBQuery1DEPT_NO: TIBStringField;
34			IBQuery1EMP_NO: TSmallintField;
35			IBQuery1FIRST_NAME: TIBStringField;
36			IBQuery1FULL_NAME: TIBStringField;
37			IBQuery1HIRE_DATE: TDateTimeField;
38			IBQuery1JOB_CODE: TIBStringField;
39			IBQuery1JOB_COUNTRY: TIBStringField;
40			IBQuery1JOB_GRADE: TSmallintField;
41			IBQuery1LAST_NAME: TIBStringField;
42			IBQuery1PHONE_EXT: TIBStringField;
43			IBTransaction1: TIBTransaction;
44			procedure AddEmployeeExecute(Sender: TObject);
45			procedure CancelChangesExecute(Sender: TObject);
46			procedure DBGrid1DblClick(Sender: TObject);
47			procedure DeleteEmployeeExecute(Sender: TObject);
48			procedure EditEmployeeExecute(Sender: TObject);
49			procedure EditEmployeeUpdate(Sender: TObject);
50			procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
51			procedure FormShow(Sender: TObject);
52			procedure IBDatabase1AfterConnect(Sender: TObject);
53			procedure IBDatabase1BeforeDisconnect(Sender: TObject);
54			procedure IBQuery1AfterDelete(DataSet: TDataSet);
55			procedure IBQuery1AfterOpen(DataSet: TDataSet);
56			procedure IBQuery1AfterTransactionEnd(Sender: TObject);
57			procedure IBQuery1BeforeClose(DataSet: TDataSet);
58			procedure IBQuery1PostError(DataSet: TDataSet; E: EDatabaseError;
59			var DataAction: TDataAction);
60			procedure IBQuery1SALARYGetText(Sender: TField; var aText: string;
61			DisplayText: Boolean);
62			procedure SaveChangesExecute(Sender: TObject);
63			procedure SaveChangesUpdate(Sender: TObject);
64			private
65			{ private declarations }
66			FDirty: boolean;
67			FClosing: boolean;
68			FLastEmp_no: integer;
69			procedure Reopen(Data: PtrInt);
70			public
71			{ public declarations }
72			end;
73
74			var
75			Form1: TForm1;
76
77			implementation
78
79			{$R *.lfm}
80
81			uses Unit2, Unit3, IB;
82
83			function ExtractDBException(msg: string): string;
84			var Lines: TStringList;
85			begin
86			Lines := TStringList.Create;
87			try
88			Lines.Text := msg;
89			if pos('exception',Lines[0]) = 1 then
90			Result := Lines[2]
91			else
92			Result := msg
93			finally
94			Lines.Free
95			end;
96			end;
97
98			{ TForm1 }
99
100			procedure TForm1.IBQuery1SALARYGetText(Sender: TField; var aText: string;
101			DisplayText: Boolean);
102			begin
103			if DisplayText then
104			begin
105			if Sender.IsNUll then
106			aText := ''
107			else
108			aText := FormatFloat('$#,##0.00',Sender.AsFloat)
109			end
110			else
111			aText := Sender.AsString
112			end;
113
114			procedure TForm1.SaveChangesExecute(Sender: TObject);
115			begin
116			IBQuery1.Transaction.Commit
117			end;
118
119			procedure TForm1.SaveChangesUpdate(Sender: TObject);
120			begin
121			(Sender as TAction).Enabled := FDirty
122			end;
123
124			procedure TForm1.Reopen(Data: PtrInt);
125			begin
126			with IBTransaction1 do
127			if not InTransaction then StartTransaction;
128			IBQuery1.Active := true
129			end;
130
131			procedure TForm1.AddEmployeeExecute(Sender: TObject);
132			var NewEmpNo: integer;
133			begin
134			if AddEmployeeDlg.ShowModal(NewEmpNo) = mrOK then
135			begin
136			FDirty := true;
137			IBQuery1.Active := false;
138			FLastEmp_no := NewEmpNo;
139			IBQuery1.Active := true
140			end;
141			end;
142
143			procedure TForm1.CancelChangesExecute(Sender: TObject);
144			begin
145			IBQuery1.Transaction.Rollback
146			end;
147
148			procedure TForm1.DBGrid1DblClick(Sender: TObject);
149			begin
150			if IBQuery1.Active and (IBQuery1.RecordCount > 0) then
151			EditEmployeeExecute(nil)
152			end;
153
154			procedure TForm1.DeleteEmployeeExecute(Sender: TObject);
155			begin
156			if MessageDlg(
157			Format('Remove %s from Employee List?',[IBQuery1.FieldByName('Full_Name').AsString]),
158			mtConfirmation,[mbYes,mbNo],0) = mrYes then
159			IBQuery1.Delete
160			end;
161
162			procedure TForm1.EditEmployeeExecute(Sender: TObject);
163			begin
164			if EditEmployeeDlg.ShowModal(IBQuery1.FieldByName('Emp_No').AsInteger) = mrOK then
165			begin
166			FDirty := true;
167			IBQuery1.Refresh
168			end;
169			end;
170
171			procedure TForm1.EditEmployeeUpdate(Sender: TObject);
172			begin
173			(Sender as TAction).Enabled := IBQuery1.Active and (IBQuery1.RecordCount > 0)
174			end;
175
176			procedure TForm1.FormClose(Sender: TObject; var CloseAction: TCloseAction);
177			begin
178			FClosing := true
179			end;
180
181			procedure TForm1.FormShow(Sender: TObject);
182			begin
183			FLastEmp_no := -1;
184			IBQuery1.Active := true
185			end;
186
187			procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
188			begin
189			with IBTransaction1 do
190			if not InTransaction then StartTransaction
191			end;
192
193			procedure TForm1.IBDatabase1BeforeDisconnect(Sender: TObject);
194			begin
195			FClosing := true
196			end;
197
198			procedure TForm1.IBQuery1AfterDelete(DataSet: TDataSet);
199			begin
200			FDirty := true
201			end;
202
203			procedure TForm1.IBQuery1AfterOpen(DataSet: TDataSet);
204			begin
205			if FLastEmp_no <> -1 then
206			DataSet.Locate('EMP_NO',FLastEmp_no,[])
207			end;
208
209			procedure TForm1.IBQuery1AfterTransactionEnd(Sender: TObject);
210			begin
211			FDirty := false;
212			if not FClosing then
213			Application.QueueAsyncCall(@Reopen,0)
214			end;
215
216			procedure TForm1.IBQuery1BeforeClose(DataSet: TDataSet);
217			begin
218			FLastEmp_no := DataSet.FieldByName('Emp_no').AsInteger
219			end;
220
221			procedure TForm1.IBQuery1PostError(DataSet: TDataSet; E: EDatabaseError;
222			var DataAction: TDataAction);
223			begin
224			if E is EIBError then
225			begin
226			MessageDlg(ExtractDBException(EIBError(E).message),mtError,[mbOK],0);
227			DataSet.Cancel;
228			DataAction := daAbort
229			end;
230			end;
231
232			end.
233