examples/scriptengine/unit1.pas

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  ComCtrls, ActnList, ExtCtrls, ibxscript, IBDatabase, IB;

type

  { TForm1 }

  TForm1 = class(TForm)
    EchoInput: TCheckBox;
    OpenBlobDialog: TOpenDialog;
    StopOnError: TCheckBox;
    RunScript: TAction;
    LoadScript: TAction;
    ActionList1: TActionList;
    Button1: TButton;
    Button2: TButton;
    IBDatabase1: TIBDatabase;
    IBTransaction1: TIBTransaction;
    IBXScript1: TIBXScript;
    Label1: TLabel;
    Label2: TLabel;
    IBScript: TMemo;
    Label3: TLabel;
    DBName: TLabel;
    OpenDialog1: TOpenDialog;
    ProgressBar1: TProgressBar;
    ResultsLog: TMemo;
    Timer1: TTimer;
    procedure EchoInputChange(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure IBDatabase1BeforeConnect(Sender: TObject);
    procedure IBXScript1GetParamValue(Sender: TObject; ParamName: string;
      var BlobID: TISC_QUAD);
    procedure IBXScript1LogProc(Sender: TObject; Msg: string);
    procedure IBXScript1ProgressEvent(Sender: TObject; Reset: boolean;
      value: integer);
    procedure IBXScript1SelectSQL(Sender: TObject; SQLText: string);
    procedure LoadScriptExecute(Sender: TObject);
    procedure RunScriptExecute(Sender: TObject);
    procedure RunScriptUpdate(Sender: TObject);
    procedure StopOnErrorChange(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { private declarations }
    procedure DoOpen(Data: PtrInt);
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

uses IBBlob, DB, Unit2;

{$R *.lfm}

{ TForm1 }

procedure TForm1.FormShow(Sender: TObject);
begin
  ResultsLog.Lines.Clear;
  IBScript.Lines.Clear;
  DBName.Caption := IBDatabase1.DatabaseName;
  StopOnError.Checked := IBXScript1.StopOnFirstError;
  EchoInput.Checked :=  IBXScript1.Echo;
//  Application.QueueAsyncCall(@DoOpen,0);
end;

procedure TForm1.IBDatabase1BeforeConnect(Sender: TObject);
begin
  with (Sender as TIBDatabase) do
  begin
    LoginPrompt := (Params.IndexOfName('user_name') = -1) or
                   (Params.IndexOfName('password') = -1);
  end;
end;

procedure TForm1.EchoInputChange(Sender: TObject);
begin
  IBXScript1.Echo :=  EchoInput.Checked;
end;

procedure TForm1.IBXScript1GetParamValue(Sender: TObject; ParamName: string;
  var BlobID: TISC_QUAD);
var Blob: TIBBlobStream;
    Source: TStream;
begin
  OpenBlobDialog.Title := 'Resolve Query Parameter: ''' + ParamName + '''';
  if OpenBlobDialog.Execute then
  begin
    ResultsLog.Lines.Add('Loading ' + ParamName + ' from ' + OpenBlobDialog.FileName);
    Blob := TIBBlobStream.Create;
    try
      Blob.Database := (Sender as TIBXScript).Database;
      Blob.Mode := bmWrite;
      Source := TFileStream.Create(OpenBlobDialog.FileName,fmOpenRead or fmShareDenyNone);
      try
        Blob.CopyFrom(Source,0)
      finally
        Source.Free;
      end;
      Blob.Finalize;
      BlobID := Blob.BlobID;
    finally
      Blob.Free;
    end;
  end
  else
    raise Exception.Create('Unable to resolve statement parameter');
end;

procedure TForm1.IBXScript1LogProc(Sender: TObject; Msg: string);
begin
  ResultsLog.Lines.Add(Msg);
end;

procedure TForm1.IBXScript1ProgressEvent(Sender: TObject; Reset: boolean;
  value: integer);
begin
  if Reset then
  begin
    ProgressBar1.Position :=  0;
    ProgressBar1.Max := value;
  end
  else
    ProgressBar1.StepIt;
end;

procedure TForm1.IBXScript1SelectSQL(Sender: TObject; SQLText: string);
begin
  with TSelectSQLResults.Create(Application) do
    Show(SQLText);
end;

procedure TForm1.LoadScriptExecute(Sender: TObject);
begin
  if OpenDialog1.Execute then
    IBScript.Lines.LoadFromFile(OpenDialog1.FileName);
end;

procedure TForm1.RunScriptExecute(Sender: TObject);
begin
  ResultsLog.Lines.Clear;
  IBXScript1.RunScript(IBScript.Lines);
  Timer1.Interval := 1000;
  EchoInput.Checked := IBXScript1.Echo;
  StopOnError.Checked := IBXScript1.StopOnFirstError;
  DBName.Caption := IBDatabase1.DatabaseName;
end;

procedure TForm1.RunScriptUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled := IBScript.Lines.Text <> '';
end;

procedure TForm1.StopOnErrorChange(Sender: TObject);
begin
   IBXScript1.StopOnFirstError := StopOnError.Checked;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  Timer1.Interval := 0;
  ProgressBar1.Position := 0;
end;

procedure TForm1.DoOpen(Data: PtrInt);
begin
  try
    IBDatabase1.Connected := true;
  except on E: Exception do
    begin
      MessageDlg(E.Message,mtError,[mbOK],0);
      Application.Terminate;
    end;
  end;
end;

end.

Revision:	47
Committed:	Mon Jan 9 15:31:51 2017 UTC (7 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	4658 byte(s)
Log Message:	Committing updates for Release R2-0-1
#	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