这两天研究了一下脚本语言，用的RO带的Pascal Script
程序的功能是 在form1中执行脚本 创建form2窗体，并让form2能和form1 能进行交互
备注：uPSI_Unit2文件 是用PSUnitImporter.exe导出来的
PSUnitImporter.exe 在D:\Program Files\RemObjects Software\Pascal Script for Delphi\Bin（本机安装目录）。
下面是程序源码
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Unit2, uPSComponent;
type
TForm1 = class(TForm)
mmo1: TMemo;
btn1: TButton;
btn2: TButton;
procedure btn1Click(Sender: TObject);
procedure btn2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
filepath: string;
procedure ShowNewMessage(const Message: string);
procedure setFilepath(str: string);
end;
var
Form1: TForm1;
Str: string;
implementation
{$R *.dfm}
uses
uPSCompiler,uPSRuntime,uPSC_std,uPSC_controls, uPSC_stdctrls,uPSC_forms,
uPSR_std,uPSR_controls,uPSR_stdctrls,uPSR_forms,uPSC_graphics,uPSI_Unit2;
function ScriptOnUses(Sender: TPSPascalCompiler; const Name: string): Boolean;
{ the OnUses callback function is called for each "uses" in the script.
It's always called with the parameter 'SYSTEM' at the top of the script.
For example: uses ii1, ii2;
This will call this function 3 times. First with 'SYSTEM' then 'II1' and then 'II2'.
}
begin
if Name = 'SYSTEM' then begin
SIRegister_Std(Sender);
{ This will register the declarations of these classes:
TObject, TPersisent.
This procedure can be found in the uPSC_std.pas unit. }
SIRegister_Controls(Sender);
{ This will register the declarations of these classes:
TControl, TWinControl, TFont, TStrings, TStringList, TGraphicControl.
This procedure can be found in the uPSC_controls.pas unit. }
SIRegister_Graphics(Sender, True);
{ 注册图像颜色}
SIRegister_Forms(Sender);
{ This will register: TScrollingWinControl, TCustomForm, TForm and TApplication.
This procedure can be found in the uPSC_forms.pas unit. }
SIRegister_stdctrls(Sender);
{ This will register: TButtonContol, TButton, TCustomCheckbox, TCheckBox, TCustomEdit,
TEdit, TCustomMemo, TMemo, TCustomLabel and TLabel.
This procedure can be found in the uPSC_stdctrls.pas unit. }
AddImportedClassVariable(Sender, 'Application', 'TApplication');
// Registers the application variable to the script engine.
SIRegister_TForm2(Sender);
SIRegister_Unit2(Sender);
{自定义类要在最后注册，在运行的时候 还要在runtime中注册，在btn1Click中可以看到}
Result := True;
end else
Result := False;
end;
procedure TForm1.ShowNewMessage(const Message: string);
begin
ShowMessage('ShowNewMessage invoked:'#13#10 + Message);
end;
procedure TForm1.btn1Click(Sender: TObject);
var
Compiler: TPSPascalCompiler;
{脚本编译器 TPSPascalCompiler is the compiler part of the script engine. This will
translate a Pascal script into compiled data for the executer. }
Exec: TPSExec;
{脚本执行 TPSExec is the executer part of the script engine. It uses the output of
the compiler to run a script. }
Data, Script: string;
CI: TPSRuntimeClassImporter;
i: Integer;
begin
Str := 'abc';
Compiler := TPSPascalCompiler.Create; // create an instance of the compiler.
Compiler.OnUses := ScriptOnUses; // assign the OnUses event.
Script := mmo1.Text;
if not Compiler.Compile(Script) then
begin // Compile the Pascal script into bytecode.
for i := 0 to Compiler.MsgCount - 1 do
begin
ShowMessage(Compiler.Msg[i].MessageToString);
//如果有错误在这里可以提示出来
end;
Compiler.Free;
// You could raise an exception here.
Exit;
end;
Compiler.GetOutput(Data); // Save the output of the compiler in the string Data.
Compiler.Free; // After compiling the script, there is no need for the compiler anymore.
CI := TPSRuntimeClassImporter.Create;
{ Create an instance of the runtime class importer.}
RIRegister_Std(CI); // uPSR_std.pas unit.
RIRegister_Controls(CI); // uPSR_controls.pas unti.
RIRegister_stdctrls(CI); // uPSR_stdctrls.pas unit.
RIRegister_Forms(CI); // uPSR_forms.pas unit.
RIRegister_TForm2(CI);
RIRegister_Unit2(CI);
Exec := TPSExec.Create; // Create an instance of the executer.
RegisterClassLibraryRuntime(Exec, CI);
// Assign the runtime class importer to the executer.
if not Exec.LoadData(Data) then begin // Load the data from the Data string.
{ For some reason the script could not be loaded. This is usually the case when a
library that has been used at compile time isn't registered at runtime. }
Exec.Free;
// You could raise an exception here.
Exit;
end;
SetVariantToClass(Exec.GetVarNo(Exec.GetVar('APPLICATION')), Application);
// This will set the script's Application variable to the real Application variable.
Exec.RunScript; // Run the script.
Exec.Free; // Free the executer.
CI.Free; // Free the runtime class importer.
end;
procedure TForm1.btn2Click(Sender: TObject);
begin
//测试用 验证Form2设置了该值没有
ShowMessage(filepath);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
//测试用
filepath := ExtractFilePath(Application.ExeName);
end;
procedure TForm1.setFilepath(str: string);
begin
//供form2 测试用
filepath := str;
end;
end.
---unit1 窗体文件
object Form1: TForm1
Left = 210
Top = 175
Width = 514
Height = 644
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object mmo1: TMemo
Left = 16
Top = 16
Width = 385
Height = 537
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -24
Font.Name = 'MS Sans Serif'
Font.Style = []
Lines.Strings = (
'var f: TForm2; i: Longint; '
'begin'
' f := TForm2.Create(nil); '
'f.Show; '
'f.caption:=''hello--script'';'
'f.color:=clOlive;'
'while f.Visible do '
'Application.ProcessMessages;'
' F.free; '
'end.')
ParentFont = False
TabOrder = 0
end
object btn1: TButton
Left = 408
Top = 24
Width = 75
Height = 25
Caption = '执行脚本'
TabOrder = 1
OnClick = btn1Click
end
object btn2: TButton
Left = 408
Top = 56
Width = 75
Height = 25
Caption = '验证'
TabOrder = 2
OnClick = btn2Click
end
end
--unit2源码
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm2 = class(TForm)
edt1: TEdit;
btn1: TButton;
btn2: TButton;
procedure btn1Click(Sender: TObject);
procedure btn2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
uses Unit1;
procedure TForm2.btn1Click(Sender: TObject);
begin
edt1.Text:=Form1.filepath;
ShowMessage(edt1.Text);
end;
procedure TForm2.btn2Click(Sender: TObject);
begin
Form1.setFilepath('hello 测试哦！');
end;
end.
--unit2窗体文件
object Form2: TForm2
Left = 411
Top = 297
Width = 395
Height = 236
Caption = 'Form2'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object edt1: TEdit
Left = 8
Top = 24
Width = 257
Height = 21
TabOrder = 0
Text = 'edt1'
end
object btn1: TButton
Left = 32
Top = 80
Width = 75
Height = 25
Caption = 'btn1'
TabOrder = 1
OnClick = btn1Click
end
object btn2: TButton
Left = 128
Top = 80
Width = 75
Height = 25
Caption = 'btn2'
TabOrder = 2
OnClick = btn2Click
end
end
--uPSI_Unit2文件
unit uPSI_Unit2;
{
This file has been generated by UnitParser v0.7, written by M. Knight
and updated by NP. v/d Spek and George Birbilis.
Source Code from Carlo Kok has been used to implement various sections of
UnitParser. Components of ROPS are used in the construction of UnitParser,
code implementing the class wrapper is taken from Carlo Kok's conv utility
}
interface
uses
SysUtils
,Classes
,uPSComponent
,uPSRuntime
,uPSCompiler
;
type
(*----------------------------------------------------------------------------*)
TPSImport_Unit2 = class(TPSPlugin)
protected
procedure CompileImport1(CompExec: TPSScript); override;
procedure ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter); override;
end;
{ compile-time registration functions }
procedure SIRegister_TForm2(CL: TPSPascalCompiler);
procedure SIRegister_Unit2(CL: TPSPascalCompiler);
{ run-time registration functions }
procedure RIRegister_TForm2(CL: TPSRuntimeClassImporter);
procedure RIRegister_Unit2(CL: TPSRuntimeClassImporter);
procedure Register;
implementation
uses
Windows
,Messages
,Variants
,Graphics
,Controls
,Forms
,Dialogs
,StdCtrls
,Unit2
;
procedure Register;
begin
RegisterComponents('Pascal Script', [TPSImport_Unit2]);
end;
(* === compile-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure SIRegister_TForm2(CL: TPSPascalCompiler);
begin
//with RegClassS(CL,'TForm', 'TForm2') do
with CL.AddClassN(CL.FindClass('TForm'),'TForm2') do
begin
RegisterProperty('edt1', 'TEdit', iptrw);
RegisterProperty('btn1', 'TButton', iptrw);
end;
end;
(*----------------------------------------------------------------------------*)
procedure SIRegister_Unit2(CL: TPSPascalCompiler);
begin
SIRegister_TForm2(CL);
end;
(* === run-time registration functions === *)
(*----------------------------------------------------------------------------*)
procedure TForm2btn1_W(Self: TForm2; const T: TButton);
Begin Self.btn1 := T; end;
(*----------------------------------------------------------------------------*)
procedure TForm2btn1_R(Self: TForm2; var T: TButton);
Begin T := Self.btn1; end;
(*----------------------------------------------------------------------------*)
procedure TForm2edt1_W(Self: TForm2; const T: TEdit);
Begin Self.edt1 := T; end;
(*----------------------------------------------------------------------------*)
procedure TForm2edt1_R(Self: TForm2; var T: TEdit);
Begin T := Self.edt1; end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_TForm2(CL: TPSRuntimeClassImporter);
begin
with CL.Add(TForm2) do
begin
RegisterPropertyHelper(@TForm2edt1_R,@TForm2edt1_W,'edt1');
RegisterPropertyHelper(@TForm2btn1_R,@TForm2btn1_W,'btn1');
end;
end;
(*----------------------------------------------------------------------------*)
procedure RIRegister_Unit2(CL: TPSRuntimeClassImporter);
begin
RIRegister_TForm2(CL);
end;
{ TPSImport_Unit2 }
(*----------------------------------------------------------------------------*)
procedure TPSImport_Unit2.CompileImport1(CompExec: TPSScript);
begin
SIRegister_Unit2(CompExec.Comp);
end;
(*----------------------------------------------------------------------------*)
procedure TPSImport_Unit2.ExecImport1(CompExec: TPSScript; const ri: TPSRuntimeClassImporter);
begin
RIRegister_Unit2(ri);
end;
(*----------------------------------------------------------------------------*)
end.
