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
#	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	tony	47	procedure IBDatabase1BeforeConnect(Sender: TObject);
39	tony	37	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	tony	47	// Application.QueueAsyncCall(@DoOpen,0);
76	tony	37	end;
77
78	tony	47	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	tony	37	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	tony	47	IBXScript1.RunScript(IBScript.Lines);
154	tony	37	Timer1.Interval := 1000;
155	tony	47	EchoInput.Checked := IBXScript1.Echo;
156			StopOnError.Checked := IBXScript1.StopOnFirstError;
157			DBName.Caption := IBDatabase1.DatabaseName;
158	tony	37	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