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 (10 years, 4 months ago) by tony
Content type:	text/x-pascal
File size:	6003 byte(s)
Log Message:	Committing updates for Release R1-1-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, IBDatabase, IBQuery, IBCustomDataSet, IBUpdateSQL, db;
10
11	type
12
13	{ TForm1 }
14
15	TForm1 = class(TForm)
16	CancelChanges: TAction;
17	IBQuery1SALARY: TIBBCDField;
18	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