examples/ibstoredproc/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, IBStoredProc, IBQuery, IBDatabaseInfo, IB,
  Unit2;

{$DEFINE LOCALDATABASE}

const
  sDatabaseName = 'sptest.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;
    GetLinesBtn: TButton;
    DataSource1: TDataSource;
    IBDatabase1: TIBDatabase;
    IBDatabaseInfo1: TIBDatabaseInfo;
    IBDynamicGrid1: TIBDynamicGrid;
    IBQuery1: TIBQuery;
    IBStoredProc1: TIBStoredProc;
    IBStoredProc2: TIBStoredProc;
    IBTransaction1: TIBTransaction;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Memo1: TMemo;
    procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure GetLinesBtnClick(Sender: TObject);
    procedure IBDatabase1CreateDatabase(Sender: TObject);
  private
    procedure DoConnectDatabase(Data: PtrInt);
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

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

procedure TForm1.ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
begin
  GetLinesBtn.Enabled := IBQuery1.Active and (IBQuery1.RecordCount > 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  IBTransaction1.Active := true;
  IBStoredProc2.ExecProc;
  IBTransaction1.Commit;
  IBTransaction1.Active := true;
  IBQuery1.Active := true;
end;

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

procedure TForm1.GetLinesBtnClick(Sender: TObject);
begin
  IBStoredProc1.ExecProc;
  Memo1.Lines.Add(IBStoredProc1.ParamByName('LINES').AsString);
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
   DBCreateForm.ShowModal;
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:	158
Committed:	Thu Mar 1 11:23:33 2018 UTC (6 years, 1 month ago) by tony
Content type:	text/x-pascal
File size:	3726 byte(s)
Log Message:	Repository resync
#	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
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, IBStoredProc, IBQuery, IBDatabaseInfo, IB,
36	Unit2;
37
38	{$DEFINE LOCALDATABASE}
39
40	const
41	sDatabaseName = 'sptest.fdb'; {If LOCALDATABASE defined then prepended with
42	path to temp folder}
43
44	{If you want to explicitly define the test database location then undefine
45	LOCALDATABASE and set explicit path e.g.
46
47	sDatabaseName = 'myserver:/databases/test.fdb';
48	}
49
50	type
51
52	{ TForm1 }
53
54	TForm1 = class(TForm)
55	ApplicationProperties1: TApplicationProperties;
56	Button1: TButton;
57	GetLinesBtn: TButton;
58	DataSource1: TDataSource;
59	IBDatabase1: TIBDatabase;
60	IBDatabaseInfo1: TIBDatabaseInfo;
61	IBDynamicGrid1: TIBDynamicGrid;
62	IBQuery1: TIBQuery;
63	IBStoredProc1: TIBStoredProc;
64	IBStoredProc2: TIBStoredProc;
65	IBTransaction1: TIBTransaction;
66	Label1: TLabel;
67	Label2: TLabel;
68	Label3: TLabel;
69	Memo1: TMemo;
70	procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
71	procedure Button1Click(Sender: TObject);
72	procedure FormCreate(Sender: TObject);
73	procedure FormShow(Sender: TObject);
74	procedure GetLinesBtnClick(Sender: TObject);
75	procedure IBDatabase1CreateDatabase(Sender: TObject);
76	private
77	procedure DoConnectDatabase(Data: PtrInt);
78	public
79
80	end;
81
82	var
83	Form1: TForm1;
84
85	implementation
86
87	{$R *.lfm}
88
89	{ TForm1 }
90
91	procedure TForm1.FormCreate(Sender: TObject);
92	begin
93	{$IFNDEF LOCALDATABASE}
94	IBDatabase1.DatabaseName := sDatabaseName
95	{$ENDIF}
96	end;
97
98	procedure TForm1.ApplicationProperties1Idle(Sender: TObject; var Done: Boolean);
99	begin
100	GetLinesBtn.Enabled := IBQuery1.Active and (IBQuery1.RecordCount > 0);
101	end;
102
103	procedure TForm1.Button1Click(Sender: TObject);
104	begin
105	IBTransaction1.Active := true;
106	IBStoredProc2.ExecProc;
107	IBTransaction1.Commit;
108	IBTransaction1.Active := true;
109	IBQuery1.Active := true;
110	end;
111
112	procedure TForm1.FormShow(Sender: TObject);
113	begin
114	Memo1.Lines.Clear;
115	Application.QueueAsyncCall(@DoConnectDatabase,0);
116	end;
117
118	procedure TForm1.GetLinesBtnClick(Sender: TObject);
119	begin
120	IBStoredProc1.ExecProc;
121	Memo1.Lines.Add(IBStoredProc1.ParamByName('LINES').AsString);
122	end;
123
124	procedure TForm1.IBDatabase1CreateDatabase(Sender: TObject);
125	begin
126	if IBDatabaseInfo1.ODSMajorVersion < 12 then
127	begin
128	IBDatabase1.DropDatabase;
129	raise EIBClientError.Create(0,'This example requires Firebird 3');
130	end
131	else
132	DBCreateForm.ShowModal;
133	end;
134
135	procedure TForm1.DoConnectDatabase(Data: PtrInt);
136	begin
137	repeat
138	try
139	IBDatabase1.Connected := true;
140	except
141	on E:EIBClientError do
142	begin
143	Close;
144	Exit
145	end;
146	On E:Exception do
147	MessageDlg(E.Message,mtError,[mbOK],0);
148	end;
149	until IBDatabase1.Connected;
150	end;
151
152	end.
153