ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/employee/unit1.pas
Revision: 19
Committed: Mon Jul 7 13:00:15 2014 UTC (9 years, 8 months ago) by tony
Content type: text/x-pascal
File size: 6003 byte(s)
Log Message:
Committing updates for Release R1-1-0

File Contents

# 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