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, 4 months ago) by tony
Content type:	text/x-pascal
File size:	6438 byte(s)
Log Message:	Committing updates for Release R2-0-0
#	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			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