arrays/1Darray/Unit1.pas

(*
 *  IBX For Lazarus (Firebird Express)
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2015 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
  DbCtrls, StdCtrls, db, DBControlGrid, IBArrayGrid,  IBDatabase,
  IBCustomDataSet, IB;

{$DEFINE LOCALDATABASE}

const
  sDatabaseName = '1Dtest.fdb'; {If LOCALDATABASE defined then prepended with
                               path to temp folder}

  {If you want to explicitly define the test database location then undefine
  LOCALDATABASE and set explicit path e.g.

  sDatabaseName = 'myserver:/databases/test.fdb';
  }

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    IBArrayGrid1: TIBArrayGrid;
    IBDataSet1MYARRAY: TIBArrayField;
    IBDataSet1ROWID: TIntegerField;
    IBDataSet1TITLE: TIBStringField;
    Panel2: TPanel;
    SaveBtn: TButton;
    CancelBtn: TButton;
    DataSource1: TDataSource;
    DBControlGrid1: TDBControlGrid;
    DBEdit1: TDBEdit;
    IBDatabase1: TIBDatabase;
    IBDataSet1: TIBDataSet;
    IBTransaction1: TIBTransaction;
    Label1: TLabel;
    Label2: TLabel;
    Panel1: TPanel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure CancelBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure IBDatabase1AfterConnect(Sender: TObject);
    procedure IBDatabase1CreateDatabase(Sender: TObject);
    procedure IBDataSet1AfterEdit(DataSet: TDataSet);
    procedure IBDataSet1AfterOpen(DataSet: TDataSet);
    procedure IBTransaction1AfterTransactionEnd(Sender: TObject);
    procedure SaveBtnClick(Sender: TObject);
  private
    { private declarations }
    procedure DoConnectDatabase(Data: PtrInt);
    procedure ReOpen(Data: PtrInt);
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

const
  sqlCreateTable =
    'Create Table TestData ('+
    'RowID Integer not null,'+
    'Title VarChar(32) Character Set UTF8,'+
    'MyArray Double Precision [1:12],'+
    'Primary Key(RowID)'+
    ')';

  sqlCreateGenerator = 'Create Generator ROWNUMBER';
  sqlSetGenerator = 'Set Generator ROWNUMBER to ';

  sqlInsert = 'Insert into TestData(RowID,Title) Values(:RowID,:Title)';

  sqlUpdate = 'Update TestData Set MyArray = ? Where RowID = ?';


{ TForm1 }

procedure TForm1.IBDatabase1CreateDatabase(Sender: TObject);
var Transaction: ITransaction;
    Statement: IStatement;
    ResultSet: IResultSet;
    row, i,j,k : integer;
    ar: IArray;
    c: char;
begin
  with IBDatabase1.Attachment do
  begin
    ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable); {Create the table}
    ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateGenerator); {Create the table}
    {Now Populate it}
    Transaction := StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
    Statement := Prepare(Transaction,'Select * from TestData');
    for row := 1 to 3 do
    begin
      Statement := PrepareWithNamedParameters(Transaction,sqlInsert);
      with Statement.GetSQLParams do
      begin
        ByName('rowid').AsInteger := row;
        ByName('title').AsString := 'Sales Agent ' + IntToStr(row);
      end;
      Statement.Execute;

      Statement := Prepare(Transaction,sqlUpdate);
      ar := CreateArray(Transaction,'TestData','MyArray');
      if ar <> nil then
      begin
        for i := 1 to 12 do
          ar.SetAsDouble([i], abs(row + 16.45 * (6-i))); {sort of randomish formula}
        Statement.SQLParams[0].AsArray := ar;
        Statement.SQLParams[1].AsInteger := row;
        Statement.Execute;
      end;
    end;
    ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlSetGenerator + '4'); {update the generator}
  end;
end;

procedure TForm1.IBDataSet1AfterEdit(DataSet: TDataSet);
begin
  SaveBtn.Enabled := true;
  CancelBtn.Enabled := true;
end;

procedure TForm1.IBDataSet1AfterOpen(DataSet: TDataSet);
begin
  SaveBtn.Enabled := false;
  CancelBtn.Enabled := false;
end;

procedure TForm1.IBTransaction1AfterTransactionEnd(Sender: TObject);
begin
  if not (csDestroying in ComponentState) then
    Application.QueueAsyncCall(@ReOpen,0);
end;

procedure TForm1.SaveBtnClick(Sender: TObject);
begin
  with IBTransaction1 do
    if InTransaction then Commit;
end;

procedure TForm1.DoConnectDatabase(Data: PtrInt);
begin
  repeat
    try
      IBDatabase1.Connected := true;
    except
     on E:EIBClientError do
      begin
        Close;
        Exit
      end;
    On E:Exception do
     MessageDlg(E.Message,mtError,[mbOK],0);
    end;
  until IBDatabase1.Connected;
end;

procedure TForm1.ReOpen(Data: PtrInt);
begin
  if not (csDestroying in ComponentState) then
    IBDataSet1.Active := true;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  Application.QueueAsyncCall(@DoConnectDatabase,0);
end;

procedure TForm1.CancelBtnClick(Sender: TObject);
begin
  with IBTransaction1 do
    if InTransaction then Rollback;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  {$IFDEF LOCALDATABASE}
  IBDatabase1.DatabaseName := GetTempDir + sDatabaseName
  {$else}
  IBDatabase1.DatabaseName := sDatabaseName
  {$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  IBDataSet1.Append;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if MessageDlg('Do you really want to delete this row?',mtConfirmation,[mbYes,mbNo],0) = mrYes then
    IBDataSet1.Delete;
end;

procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
begin
  IBDataSet1.Active := true
end;

end.

Revision:	45
Committed:	Tue Dec 6 10:33:46 2016 UTC (7 years, 11 months ago) by tony
Content type:	text/x-pascal
File size:	6438 byte(s)
Log Message:	Committing updates for Release R2-0-0
#	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