arrays/2Darray/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, DbCtrls, db,
  IBArrayGrid, IBDatabase, IBQuery, IBCustomDataSet, IB;

{$DEFINE LOCALDATABASE}

const
  sDatabaseName = '2Dtest.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)
    DataSource1: TDataSource;
    DBEdit1: TDBEdit;
    DBNavigator1: TDBNavigator;
    IBArrayGrid1: TIBArrayGrid;
    IBDatabase1: TIBDatabase;
    IBDataSet1: TIBDataSet;
    IBTransaction1: TIBTransaction;
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure IBDatabase1AfterConnect(Sender: TObject);
    procedure IBDatabase1CreateDatabase(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.FormShow(Sender: TObject);
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.FormCreate(Sender: TObject);
begin
  {$IFNDEF LOCALDATABASE}
  IBDatabase1.DatabaseName := sDatabaseName
  {$ENDIF}
end;

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

const
  sqlCreateTable =
    'Create Table TestData ('+
    'RowID Integer not null,'+
    'Title VarChar(32) Character Set UTF8,'+
    'MyArray VarChar(16) [0:16, -1:7] Character Set UTF8,'+
    '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 = ?';

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 := 'Matrix ' + IntToStr(row);
      end;
      Statement.Execute;

      Statement := Prepare(Transaction,sqlUpdate);
      if row > 2 then continue;
      ar := CreateArray(Transaction,'TestData','MyArray');
      if ar <> nil then
      begin
        k := 0;
        c := chr(ord('A') + row - 1);
        for i := 0 to 16 do
          for j := -1 to 7 do
          begin
            ar.SetAsString([i,j],c + IntToStr(k));
            Inc(k);
          end;
        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;

end.

Revision:	410
Committed:	Thu Jun 22 13:52:39 2023 UTC (17 months ago) by tony
Content type:	text/x-pascal
File size:	4595 byte(s)
Log Message:	Release 2.6.0 beta
#	User	Rev	Content
1	tony	45	(*
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
27			unit Unit1;
28
29			{$mode objfpc}{$H+}
30
31			interface
32
33			uses
34			Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, DbCtrls, db,
35			IBArrayGrid, IBDatabase, IBQuery, IBCustomDataSet, IB;
36
37			{$DEFINE LOCALDATABASE}
38
39			const
40			sDatabaseName = '2Dtest.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			DataSource1: TDataSource;
55			DBEdit1: TDBEdit;
56			DBNavigator1: TDBNavigator;
57			IBArrayGrid1: TIBArrayGrid;
58			IBDatabase1: TIBDatabase;
59			IBDataSet1: TIBDataSet;
60			IBTransaction1: TIBTransaction;
61			procedure FormCreate(Sender: TObject);
62			procedure FormShow(Sender: TObject);
63			procedure IBDatabase1AfterConnect(Sender: TObject);
64			procedure IBDatabase1CreateDatabase(Sender: TObject);
65			private
66			{ private declarations }
67			public
68			{ public declarations }
69			end;
70
71			var
72			Form1: TForm1;
73
74			implementation
75
76			{$R *.lfm}
77
78			{ TForm1 }
79
80			procedure TForm1.FormShow(Sender: TObject);
81			begin
82			repeat
83			try
84			IBDatabase1.Connected := true;
85			except
86			on E:EIBClientError do
87			begin
88			Close;
89			Exit
90			end;
91			On E:Exception do
92			MessageDlg(E.Message,mtError,[mbOK],0);
93			end;
94			until IBDatabase1.Connected;
95			end;
96
97			procedure TForm1.FormCreate(Sender: TObject);
98			begin
99	tony	143	{$IFNDEF LOCALDATABASE}
100	tony	45	IBDatabase1.DatabaseName := sDatabaseName
101			{$ENDIF}
102			end;
103
104			procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
105			begin
106			IBDataSet1.Active := true;
107			end;
108
109			const
110			sqlCreateTable =
111			'Create Table TestData ('+
112			'RowID Integer not null,'+
113			'Title VarChar(32) Character Set UTF8,'+
114			'MyArray VarChar(16) [0:16, -1:7] Character Set UTF8,'+
115			'Primary Key(RowID)'+
116			')';
117
118			sqlCreateGenerator = 'Create Generator ROWNUMBER';
119			sqlSetGenerator = 'Set Generator ROWNUMBER to ';
120
121			sqlInsert = 'Insert into TestData(RowID,Title) Values(:RowID,:Title)';
122
123			sqlUpdate = 'Update TestData Set MyArray = ? Where RowID = ?';
124
125			procedure TForm1.IBDatabase1CreateDatabase(Sender: TObject);
126			var Transaction: ITransaction;
127			Statement: IStatement;
128			ResultSet: IResultSet;
129			row, i,j,k : integer;
130			ar: IArray;
131			c: char;
132			begin
133			with IBDatabase1.Attachment do
134			begin
135			ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable); {Create the table}
136			ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateGenerator); {Create the table}
137			{Now Populate it}
138			Transaction := StartTransaction([isc_tpb_write,isc_tpb_nowait,isc_tpb_concurrency],taCommit);
139			Statement := Prepare(Transaction,'Select * from TestData');
140			for row := 1 to 3 do
141			begin
142			Statement := PrepareWithNamedParameters(Transaction,sqlInsert);
143			with Statement.GetSQLParams do
144			begin
145			ByName('rowid').AsInteger := row;
146	tony	410	ByName('title').AsString := 'Matrix ' + IntToStr(row);
147	tony	45	end;
148			Statement.Execute;
149
150			Statement := Prepare(Transaction,sqlUpdate);
151			if row > 2 then continue;
152			ar := CreateArray(Transaction,'TestData','MyArray');
153			if ar <> nil then
154			begin
155			k := 0;
156			c := chr(ord('A') + row - 1);
157			for i := 0 to 16 do
158			for j := -1 to 7 do
159			begin
160			ar.SetAsString([i,j],c + IntToStr(k));
161			Inc(k);
162			end;
163			Statement.SQLParams[0].AsArray := ar;
164			Statement.SQLParams[1].AsInteger := row;
165			Statement.Execute;
166			end;
167			end;
168			ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlSetGenerator + '4'); {update the generator}
169			end;
170			end;
171
172			end.
173