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 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.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);
var S: TMemoryStream;
begin
  ResultsLog.Lines.Clear;
  S := TMemoryStream.Create;
  try
   IBScript.Lines.SaveToStream(S);
   S.Position := 0;
   IBXScript1.PerformUpdate(S,true);
  finally
    S.Free;
  end;
  Timer1.Interval := 1000;
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:	45
Committed:	Tue Dec 6 10:33:46 2016 UTC (7 years, 11 months ago) by tony
Content type:	text/x-pascal
File size:	4357 byte(s)
Log Message:	Committing updates for Release R2-0-0
#	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 IBXScript1GetParamValue(Sender: TObject; ParamName: string;
39	var BlobID: TISC_QUAD);
40	procedure IBXScript1LogProc(Sender: TObject; Msg: string);
41	procedure IBXScript1ProgressEvent(Sender: TObject; Reset: boolean;
42	value: integer);
43	procedure IBXScript1SelectSQL(Sender: TObject; SQLText: string);
44	procedure LoadScriptExecute(Sender: TObject);
45	procedure RunScriptExecute(Sender: TObject);
46	procedure RunScriptUpdate(Sender: TObject);
47	procedure StopOnErrorChange(Sender: TObject);
48	procedure Timer1Timer(Sender: TObject);
49	private
50	{ private declarations }
51	procedure DoOpen(Data: PtrInt);
52	public
53	{ public declarations }
54	end;
55
56	var
57	Form1: TForm1;
58
59	implementation
60
61	uses IBBlob, DB, Unit2;
62
63	{$R *.lfm}
64
65	{ TForm1 }
66
67	procedure TForm1.FormShow(Sender: TObject);
68	begin
69	ResultsLog.Lines.Clear;
70	IBScript.Lines.Clear;
71	DBName.Caption := IBDatabase1.DatabaseName;
72	StopOnError.Checked := IBXScript1.StopOnFirstError;
73	EchoInput.Checked := IBXScript1.Echo;
74	Application.QueueAsyncCall(@DoOpen,0);
75	end;
76
77	procedure TForm1.EchoInputChange(Sender: TObject);
78	begin
79	IBXScript1.Echo := EchoInput.Checked;
80	end;
81
82	procedure TForm1.IBXScript1GetParamValue(Sender: TObject; ParamName: string;
83	var BlobID: TISC_QUAD);
84	var Blob: TIBBlobStream;
85	Source: TStream;
86	begin
87	OpenBlobDialog.Title := 'Resolve Query Parameter: ''' + ParamName + '''';
88	if OpenBlobDialog.Execute then
89	begin
90	ResultsLog.Lines.Add('Loading ' + ParamName + ' from ' + OpenBlobDialog.FileName);
91	Blob := TIBBlobStream.Create;
92	try
93	Blob.Database := (Sender as TIBXScript).Database;
94	Blob.Mode := bmWrite;
95	Source := TFileStream.Create(OpenBlobDialog.FileName,fmOpenRead or fmShareDenyNone);
96	try
97	Blob.CopyFrom(Source,0)
98	finally
99	Source.Free;
100	end;
101	Blob.Finalize;
102	BlobID := Blob.BlobID;
103	finally
104	Blob.Free;
105	end;
106	end
107	else
108	raise Exception.Create('Unable to resolve statement parameter');
109	end;
110
111	procedure TForm1.IBXScript1LogProc(Sender: TObject; Msg: string);
112	begin
113	ResultsLog.Lines.Add(Msg);
114	end;
115
116	procedure TForm1.IBXScript1ProgressEvent(Sender: TObject; Reset: boolean;
117	value: integer);
118	begin
119	if Reset then
120	begin
121	ProgressBar1.Position := 0;
122	ProgressBar1.Max := value;
123	end
124	else
125	ProgressBar1.StepIt;
126	end;
127
128	procedure TForm1.IBXScript1SelectSQL(Sender: TObject; SQLText: string);
129	begin
130	with TSelectSQLResults.Create(Application) do
131	Show(SQLText);
132	end;
133
134	procedure TForm1.LoadScriptExecute(Sender: TObject);
135	begin
136	if OpenDialog1.Execute then
137	IBScript.Lines.LoadFromFile(OpenDialog1.FileName);
138	end;
139
140	procedure TForm1.RunScriptExecute(Sender: TObject);
141	var S: TMemoryStream;
142	begin
143	ResultsLog.Lines.Clear;
144	S := TMemoryStream.Create;
145	try
146	IBScript.Lines.SaveToStream(S);
147	S.Position := 0;
148	IBXScript1.PerformUpdate(S,true);
149	finally
150	S.Free;
151	end;
152	Timer1.Interval := 1000;
153	end;
154
155	procedure TForm1.RunScriptUpdate(Sender: TObject);
156	begin
157	(Sender as TAction).Enabled := IBScript.Lines.Text <> '';
158	end;
159
160	procedure TForm1.StopOnErrorChange(Sender: TObject);
161	begin
162	IBXScript1.StopOnFirstError := StopOnError.Checked;
163	end;
164
165	procedure TForm1.Timer1Timer(Sender: TObject);
166	begin
167	Timer1.Interval := 0;
168	ProgressBar1.Position := 0;
169	end;
170
171	procedure TForm1.DoOpen(Data: PtrInt);
172	begin
173	try
174	IBDatabase1.Connected := true;
175	except on E: Exception do
176	begin
177	MessageDlg(E.Message,mtError,[mbOK],0);
178	Application.Terminate;
179	end;
180	end;
181	end;
182
183	end.
184