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
#	User	Rev	Content
1	tony	37	unit Unit1;
2
3			{$mode objfpc}{$H+}
4
5			interface
6
7			uses
8			Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
9	tony	45	ComCtrls, ActnList, ExtCtrls, ibxscript, IBDatabase, IB;
10	tony	37
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