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