ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/arrays/1Darray/Unit1.pas
Revision: 45
Committed: Tue Dec 6 10:33:46 2016 UTC (7 years, 3 months ago) by tony
Content type: text/x-pascal
File size: 6438 byte(s)
Log Message:
Committing updates for Release R2-0-0

File Contents

# Content
1 (*
2 * IBX For Lazarus (Firebird Express)
3 *
4 * The contents of this file are subject to the Initial Developer's
5 * Public License Version 1.0 (the "License"); you may not use this
6 * file except in compliance with the License. You may obtain a copy
7 * of the License here:
8 *
9 * http://www.firebirdsql.org/index.php?op=doc&id=idpl
10 *
11 * Software distributed under the License is distributed on an "AS
12 * IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
13 * implied. See the License for the specific language governing rights
14 * and limitations under the License.
15 *
16 * The Initial Developer of the Original Code is Tony Whyman.
17 *
18 * The Original Code is (C) 2015 Tony Whyman, MWA Software
19 * (http://www.mwasoftware.co.uk).
20 *
21 * All Rights Reserved.
22 *
23 * Contributor(s): ______________________________________.
24 *
25 *)
26 unit Unit1;
27
28 {$mode objfpc}{$H+}
29
30 interface
31
32 uses
33 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
34 DbCtrls, StdCtrls, db, DBControlGrid, IBArrayGrid, IBDatabase,
35 IBCustomDataSet, IB;
36
37 {$DEFINE LOCALDATABASE}
38
39 const
40 sDatabaseName = '1Dtest.fdb'; {If LOCALDATABASE defined then prepended with
41 path to temp folder}
42
43 {If you want to explicitly define the test database location then undefine
44 LOCALDATABASE and set explicit path e.g.
45
46 sDatabaseName = 'myserver:/databases/test.fdb';
47 }
48
49 type
50
51 { TForm1 }
52
53 TForm1 = class(TForm)
54 Button1: TButton;
55 Button2: TButton;
56 IBArrayGrid1: TIBArrayGrid;
57 IBDataSet1MYARRAY: TIBArrayField;
58 IBDataSet1ROWID: TIntegerField;
59 IBDataSet1TITLE: TIBStringField;
60 Panel2: TPanel;
61 SaveBtn: TButton;
62 CancelBtn: TButton;
63 DataSource1: TDataSource;
64 DBControlGrid1: TDBControlGrid;
65 DBEdit1: TDBEdit;
66 IBDatabase1: TIBDatabase;
67 IBDataSet1: TIBDataSet;
68 IBTransaction1: TIBTransaction;
69 Label1: TLabel;
70 Label2: TLabel;
71 Panel1: TPanel;
72 procedure Button1Click(Sender: TObject);
73 procedure Button2Click(Sender: TObject);
74 procedure CancelBtnClick(Sender: TObject);
75 procedure FormCreate(Sender: TObject);
76 procedure FormShow(Sender: TObject);
77 procedure IBDatabase1AfterConnect(Sender: TObject);
78 procedure IBDatabase1CreateDatabase(Sender: TObject);
79 procedure IBDataSet1AfterEdit(DataSet: TDataSet);
80 procedure IBDataSet1AfterOpen(DataSet: TDataSet);
81 procedure IBTransaction1AfterTransactionEnd(Sender: TObject);
82 procedure SaveBtnClick(Sender: TObject);
83 private
84 { private declarations }
85 procedure DoConnectDatabase(Data: PtrInt);
86 procedure ReOpen(Data: PtrInt);
87 public
88 { public declarations }
89 end;
90
91 var
92 Form1: TForm1;
93
94 implementation
95
96 {$R *.lfm}
97
98 const
99 sqlCreateTable =
100 'Create Table TestData ('+
101 'RowID Integer not null,'+
102 'Title VarChar(32) Character Set UTF8,'+
103 'MyArray Double Precision [1:12],'+
104 'Primary Key(RowID)'+
105 ')';
106
107 sqlCreateGenerator = 'Create Generator ROWNUMBER';
108 sqlSetGenerator = 'Set Generator ROWNUMBER to ';
109
110 sqlInsert = 'Insert into TestData(RowID,Title) Values(:RowID,:Title)';
111
112 sqlUpdate = 'Update TestData Set MyArray = ? Where RowID = ?';
113
114
115 { TForm1 }
116
117 procedure TForm1.IBDatabase1CreateDatabase(Sender: TObject);
118 var Transaction: ITransaction;
119 Statement: IStatement;
120 ResultSet: IResultSet;
121 row, i,j,k : integer;
122 ar: IArray;
123 c: char;
124 begin
125 with IBDatabase1.Attachment do
126 begin
127 ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable); {Create the table}
128 ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateGenerator); {Create the table}
129 {Now Populate it}
130 Transaction := StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
131 Statement := Prepare(Transaction,'Select * from TestData');
132 for row := 1 to 3 do
133 begin
134 Statement := PrepareWithNamedParameters(Transaction,sqlInsert);
135 with Statement.GetSQLParams do
136 begin
137 ByName('rowid').AsInteger := row;
138 ByName('title').AsString := 'Sales Agent ' + IntToStr(row);
139 end;
140 Statement.Execute;
141
142 Statement := Prepare(Transaction,sqlUpdate);
143 ar := CreateArray(Transaction,'TestData','MyArray');
144 if ar <> nil then
145 begin
146 for i := 1 to 12 do
147 ar.SetAsDouble([i], abs(row + 16.45 * (6-i))); {sort of randomish formula}
148 Statement.SQLParams[0].AsArray := ar;
149 Statement.SQLParams[1].AsInteger := row;
150 Statement.Execute;
151 end;
152 end;
153 ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlSetGenerator + '4'); {update the generator}
154 end;
155 end;
156
157 procedure TForm1.IBDataSet1AfterEdit(DataSet: TDataSet);
158 begin
159 SaveBtn.Enabled := true;
160 CancelBtn.Enabled := true;
161 end;
162
163 procedure TForm1.IBDataSet1AfterOpen(DataSet: TDataSet);
164 begin
165 SaveBtn.Enabled := false;
166 CancelBtn.Enabled := false;
167 end;
168
169 procedure TForm1.IBTransaction1AfterTransactionEnd(Sender: TObject);
170 begin
171 if not (csDestroying in ComponentState) then
172 Application.QueueAsyncCall(@ReOpen,0);
173 end;
174
175 procedure TForm1.SaveBtnClick(Sender: TObject);
176 begin
177 with IBTransaction1 do
178 if InTransaction then Commit;
179 end;
180
181 procedure TForm1.DoConnectDatabase(Data: PtrInt);
182 begin
183 repeat
184 try
185 IBDatabase1.Connected := true;
186 except
187 on E:EIBClientError do
188 begin
189 Close;
190 Exit
191 end;
192 On E:Exception do
193 MessageDlg(E.Message,mtError,[mbOK],0);
194 end;
195 until IBDatabase1.Connected;
196 end;
197
198 procedure TForm1.ReOpen(Data: PtrInt);
199 begin
200 if not (csDestroying in ComponentState) then
201 IBDataSet1.Active := true;
202 end;
203
204 procedure TForm1.FormShow(Sender: TObject);
205 begin
206 Application.QueueAsyncCall(@DoConnectDatabase,0);
207 end;
208
209 procedure TForm1.CancelBtnClick(Sender: TObject);
210 begin
211 with IBTransaction1 do
212 if InTransaction then Rollback;
213 end;
214
215 procedure TForm1.FormCreate(Sender: TObject);
216 begin
217 {$IFDEF LOCALDATABASE}
218 IBDatabase1.DatabaseName := GetTempDir + sDatabaseName
219 {$else}
220 IBDatabase1.DatabaseName := sDatabaseName
221 {$ENDIF}
222 end;
223
224 procedure TForm1.Button1Click(Sender: TObject);
225 begin
226 IBDataSet1.Append;
227 end;
228
229 procedure TForm1.Button2Click(Sender: TObject);
230 begin
231 if MessageDlg('Do you really want to delete this row?',mtConfirmation,[mbYes,mbNo],0) = mrYes then
232 IBDataSet1.Delete;
233 end;
234
235 procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
236 begin
237 IBDataSet1.Active := true
238 end;
239
240 end.
241