examples/IdentityColumns/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, StdCtrls, db,
  IBDynamicGrid, IBDatabase, IBCustomDataSet, IBDatabaseInfo, IB;

{$DEFINE LOCALDATABASE}

const
  sDatabaseName = 'IDTest.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)
    ApplicationProperties1: TApplicationProperties;
    Button1: TButton;
    IBDatabaseInfo1: TIBDatabaseInfo;
    Label1: TLabel;
    PostBtn: TButton;
    DataSource1: TDataSource;
    IBDatabase1: TIBDatabase;
    IBDataSet1: TIBDataSet;
    IBDynamicGrid1: TIBDynamicGrid;
    IBTransaction1: TIBTransaction;
    procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure IBDatabase1AfterConnect(Sender: TObject);
    procedure IBDatabase1CreateDatabase(Sender: TObject);
    procedure PostBtnClick(Sender: TObject);
  private
    procedure DoConnectDatabase(Data: PtrInt);
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

const
  sqlCreateTable = 'CREATE TABLE IDTEST ('+
                   '"KEY" integer GENERATED BY DEFAULT AS IDENTITY, '+
                   'SOMETEXT varchar(64), '+
                   'COMPTEXT Computed By (SOMETEXT || '' has the key '' || "KEY"), '+
                   'PRIMARY KEY ("KEY") )';

{ TForm1 }

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

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

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

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

procedure TForm1.ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
begin
  PostBtn.Enabled := IBDataset1.State in [dsInsert,dsEdit];
end;

procedure TForm1.IBDatabase1CreateDatabase(Sender: TObject);
begin
  if IBDatabaseInfo1.ODSMajorVersion < 12 then
  begin
    IBDatabase1.DropDatabase;
    raise EIBClientError.Create(0,'This example requires Firebird 3');
  end
  else
  with IBDatabase1.Attachment do
    ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable); {Create the table}
end;

procedure TForm1.PostBtnClick(Sender: TObject);
begin
  IBDataset1.Post;
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;

end.

Revision:	263
Committed:	Thu Dec 6 15:55:01 2018 UTC (5 years, 4 months ago) by tony
Content type:	text/x-pascal
File size:	3944 byte(s)
Log Message:	Release 2.3.2 committed
#	User	Rev	Content
1	tony	158	(*
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, StdCtrls, db,
35			IBDynamicGrid, IBDatabase, IBCustomDataSet, IBDatabaseInfo, IB;
36
37			{$DEFINE LOCALDATABASE}
38
39			const
40			sDatabaseName = 'IDTest.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			ApplicationProperties1: TApplicationProperties;
55			Button1: TButton;
56			IBDatabaseInfo1: TIBDatabaseInfo;
57			Label1: TLabel;
58			PostBtn: TButton;
59			DataSource1: TDataSource;
60			IBDatabase1: TIBDatabase;
61			IBDataSet1: TIBDataSet;
62			IBDynamicGrid1: TIBDynamicGrid;
63			IBTransaction1: TIBTransaction;
64			procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
65			procedure Button1Click(Sender: TObject);
66			procedure FormCreate(Sender: TObject);
67			procedure FormShow(Sender: TObject);
68			procedure IBDatabase1AfterConnect(Sender: TObject);
69			procedure IBDatabase1CreateDatabase(Sender: TObject);
70			procedure PostBtnClick(Sender: TObject);
71			private
72			procedure DoConnectDatabase(Data: PtrInt);
73			public
74
75			end;
76
77			var
78			Form1: TForm1;
79
80			implementation
81
82			{$R *.lfm}
83
84			const
85			sqlCreateTable = 'CREATE TABLE IDTEST ('+
86	tony	263	'"KEY" integer GENERATED BY DEFAULT AS IDENTITY, '+
87	tony	158	'SOMETEXT varchar(64), '+
88	tony	263	'COMPTEXT Computed By (SOMETEXT \|\| '' has the key '' \|\| "KEY"), '+
89			'PRIMARY KEY ("KEY") )';
90	tony	158
91			{ TForm1 }
92
93			procedure TForm1.FormCreate(Sender: TObject);
94			begin
95			{$IFNDEF LOCALDATABASE}
96			IBDatabase1.DatabaseName := sDatabaseName
97			{$ENDIF}
98			end;
99
100			procedure TForm1.FormShow(Sender: TObject);
101			begin
102			Application.QueueAsyncCall(@DoConnectDatabase,0);
103			end;
104
105			procedure TForm1.IBDatabase1AfterConnect(Sender: TObject);
106			begin
107			IBTransaction1.Active := true;
108			IBDataset1.Active := true;
109			end;
110
111			procedure TForm1.Button1Click(Sender: TObject);
112			begin
113			IBDataset1.Append;
114			end;
115
116			procedure TForm1.ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
117			begin
118			PostBtn.Enabled := IBDataset1.State in [dsInsert,dsEdit];
119			end;
120
121			procedure TForm1.IBDatabase1CreateDatabase(Sender: TObject);
122			begin
123			if IBDatabaseInfo1.ODSMajorVersion < 12 then
124			begin
125			IBDatabase1.DropDatabase;
126			raise EIBClientError.Create(0,'This example requires Firebird 3');
127			end
128			else
129			with IBDatabase1.Attachment do
130			ExecImmediate([isc_tpb_write,isc_tpb_wait,isc_tpb_consistency],sqlCreateTable); {Create the table}
131			end;
132
133			procedure TForm1.PostBtnClick(Sender: TObject);
134			begin
135			IBDataset1.Post;
136			end;
137
138			procedure TForm1.DoConnectDatabase(Data: PtrInt);
139			begin
140			repeat
141			try
142			IBDatabase1.Connected := true;
143			except
144			on E:EIBClientError do
145			begin
146			Close;
147			Exit
148			end;
149			On E:Exception do
150			MessageDlg(E.Message,mtError,[mbOK],0);
151			end;
152			until IBDatabase1.Connected;
153			end;
154
155			end.
156