ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/examples/scriptengine/unit1.pas
Revision: 47
Committed: Mon Jan 9 15:31:51 2017 UTC (7 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 4658 byte(s)
Log Message:
Committing updates for Release R2-0-1

File Contents

# Content
1 unit Unit1;
2
3 {$mode objfpc}{$H+}
4
5 interface
6
7 uses
8 Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
9 ComCtrls, ActnList, ExtCtrls, ibxscript, IBDatabase, IB;
10
11 type
12
13 { TForm1 }
14
15 TForm1 = class(TForm)
16 EchoInput: TCheckBox;
17 OpenBlobDialog: TOpenDialog;
18 StopOnError: TCheckBox;
19 RunScript: TAction;
20 LoadScript: TAction;
21 ActionList1: TActionList;
22 Button1: TButton;
23 Button2: TButton;
24 IBDatabase1: TIBDatabase;
25 IBTransaction1: TIBTransaction;
26 IBXScript1: TIBXScript;
27 Label1: TLabel;
28 Label2: TLabel;
29 IBScript: TMemo;
30 Label3: TLabel;
31 DBName: TLabel;
32 OpenDialog1: TOpenDialog;
33 ProgressBar1: TProgressBar;
34 ResultsLog: TMemo;
35 Timer1: TTimer;
36 procedure EchoInputChange(Sender: TObject);
37 procedure FormShow(Sender: TObject);
38 procedure IBDatabase1BeforeConnect(Sender: TObject);
39 procedure IBXScript1GetParamValue(Sender: TObject; ParamName: string;
40 var BlobID: TISC_QUAD);
41 procedure IBXScript1LogProc(Sender: TObject; Msg: string);
42 procedure IBXScript1ProgressEvent(Sender: TObject; Reset: boolean;
43 value: integer);
44 procedure IBXScript1SelectSQL(Sender: TObject; SQLText: string);
45 procedure LoadScriptExecute(Sender: TObject);
46 procedure RunScriptExecute(Sender: TObject);
47 procedure RunScriptUpdate(Sender: TObject);
48 procedure StopOnErrorChange(Sender: TObject);
49 procedure Timer1Timer(Sender: TObject);
50 private
51 { private declarations }
52 procedure DoOpen(Data: PtrInt);
53 public
54 { public declarations }
55 end;
56
57 var
58 Form1: TForm1;
59
60 implementation
61
62 uses IBBlob, DB, Unit2;
63
64 {$R *.lfm}
65
66 { TForm1 }
67
68 procedure TForm1.FormShow(Sender: TObject);
69 begin
70 ResultsLog.Lines.Clear;
71 IBScript.Lines.Clear;
72 DBName.Caption := IBDatabase1.DatabaseName;
73 StopOnError.Checked := IBXScript1.StopOnFirstError;
74 EchoInput.Checked := IBXScript1.Echo;
75 // Application.QueueAsyncCall(@DoOpen,0);
76 end;
77
78 procedure TForm1.IBDatabase1BeforeConnect(Sender: TObject);
79 begin
80 with (Sender as TIBDatabase) do
81 begin
82 LoginPrompt := (Params.IndexOfName('user_name') = -1) or
83 (Params.IndexOfName('password') = -1);
84 end;
85 end;
86
87 procedure TForm1.EchoInputChange(Sender: TObject);
88 begin
89 IBXScript1.Echo := EchoInput.Checked;
90 end;
91
92 procedure TForm1.IBXScript1GetParamValue(Sender: TObject; ParamName: string;
93 var BlobID: TISC_QUAD);
94 var Blob: TIBBlobStream;
95 Source: TStream;
96 begin
97 OpenBlobDialog.Title := 'Resolve Query Parameter: ''' + ParamName + '''';
98 if OpenBlobDialog.Execute then
99 begin
100 ResultsLog.Lines.Add('Loading ' + ParamName + ' from ' + OpenBlobDialog.FileName);
101 Blob := TIBBlobStream.Create;
102 try
103 Blob.Database := (Sender as TIBXScript).Database;
104 Blob.Mode := bmWrite;
105 Source := TFileStream.Create(OpenBlobDialog.FileName,fmOpenRead or fmShareDenyNone);
106 try
107 Blob.CopyFrom(Source,0)
108 finally
109 Source.Free;
110 end;
111 Blob.Finalize;
112 BlobID := Blob.BlobID;
113 finally
114 Blob.Free;
115 end;
116 end
117 else
118 raise Exception.Create('Unable to resolve statement parameter');
119 end;
120
121 procedure TForm1.IBXScript1LogProc(Sender: TObject; Msg: string);
122 begin
123 ResultsLog.Lines.Add(Msg);
124 end;
125
126 procedure TForm1.IBXScript1ProgressEvent(Sender: TObject; Reset: boolean;
127 value: integer);
128 begin
129 if Reset then
130 begin
131 ProgressBar1.Position := 0;
132 ProgressBar1.Max := value;
133 end
134 else
135 ProgressBar1.StepIt;
136 end;
137
138 procedure TForm1.IBXScript1SelectSQL(Sender: TObject; SQLText: string);
139 begin
140 with TSelectSQLResults.Create(Application) do
141 Show(SQLText);
142 end;
143
144 procedure TForm1.LoadScriptExecute(Sender: TObject);
145 begin
146 if OpenDialog1.Execute then
147 IBScript.Lines.LoadFromFile(OpenDialog1.FileName);
148 end;
149
150 procedure TForm1.RunScriptExecute(Sender: TObject);
151 begin
152 ResultsLog.Lines.Clear;
153 IBXScript1.RunScript(IBScript.Lines);
154 Timer1.Interval := 1000;
155 EchoInput.Checked := IBXScript1.Echo;
156 StopOnError.Checked := IBXScript1.StopOnFirstError;
157 DBName.Caption := IBDatabase1.DatabaseName;
158 end;
159
160 procedure TForm1.RunScriptUpdate(Sender: TObject);
161 begin
162 (Sender as TAction).Enabled := IBScript.Lines.Text <> '';
163 end;
164
165 procedure TForm1.StopOnErrorChange(Sender: TObject);
166 begin
167 IBXScript1.StopOnFirstError := StopOnError.Checked;
168 end;
169
170 procedure TForm1.Timer1Timer(Sender: TObject);
171 begin
172 Timer1.Interval := 0;
173 ProgressBar1.Position := 0;
174 end;
175
176 procedure TForm1.DoOpen(Data: PtrInt);
177 begin
178 try
179 IBDatabase1.Connected := true;
180 except on E: Exception do
181 begin
182 MessageDlg(E.Message,mtError,[mbOK],0);
183 Application.Terminate;
184 end;
185 end;
186 end;
187
188 end.
189