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, 8 months ago) by tony
Content type:	text/x-pascal
File size:	3726 byte(s)
Log Message:	Repository resync
#	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, 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