调用脚本内函数

Unit fMain;

Interface

Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls, uPSComponent, uPSCompiler, Menus, uPSRuntime, uPSUtils;

Type
TForm1 = Class(TForm)
Memo1: TMemo;
Memo2: TMemo;
Splitter1: TSplitter;
PSScript: TPSScript;
PS3DllPlugin: TPSDllPlugin;
MainMenu1: TMainMenu;
Program1: TMenuItem;
Compile1: TMenuItem;
mniN22341: TMenuItem;
Button1: TButton;
Edit1: TEdit;
Label1: TLabel;
Procedure IFPS3ClassesPlugin1CompImport(Sender: TObject;
x: TPSPascalCompiler);
Procedure IFPS3ClassesPlugin1ExecImport(Sender: TObject; Exec: TPSExec;
x: TPSRuntimeClassImporter);
Procedure PSScriptCompile(Sender: TPSScript);
Procedure Compile1Click(Sender: TObject);
Procedure PSScriptExecute(Sender: TPSScript);
Procedure ShowNewMessage(Const Message: String);
Procedure PSScriptVerifyProc(Sender: TPSScript;
Proc: TPSInternalProcedure; Const Decl: String; Var Error: Boolean);
Procedure mniN22341Click(Sender: TObject); //自定义的过程

Private
{ Private declarations }
Public
{ Public declarations }
End;

Type
TTestFunction = Function(Param1: Double; Data: String): Longint Of Object;

Var
Form1 : TForm1;

Implementation

Uses
uPSR_std,
uPSC_std,
uPSR_stdctrls,
uPSC_stdctrls,
uPSR_forms,
uPSC_forms,
uPSC_graphics,
uPSC_controls,
uPSC_classes,
uPSR_graphics,
uPSR_controls,
uPSR_classes;

{$R *.DFM}

Procedure TForm1.ShowNewMessage(Const Message: String); //自己增加的过程，在编译事件中要注册
Begin
ShowMessage('使用的是新增加的函数:'#13#10 + Message);
End;

Procedure TForm1.IFPS3ClassesPlugin1CompImport(Sender: TObject;
x: TIFPSPascalcompiler);
Begin
SIRegister_Std(x);
SIRegister_Classes(x, true);
SIRegister_Graphics(x, true);
SIRegister_Controls(x);
SIRegister_stdctrls(x);
SIRegister_Forms(x);
End;

Procedure TForm1.IFPS3ClassesPlugin1ExecImport(Sender: TObject; Exec: TIFPSExec;
x: TIFPSRuntimeClassImporter);
Begin
RIRegister_Std(x);
RIRegister_Classes(x, True);
RIRegister_Graphics(x, True);
RIRegister_Controls(x);
RIRegister_stdctrls(x);
RIRegister_Forms(x);
End;

Function ImportTest(S1: String; s2: Longint; s3: Byte; s4: word; Var s5: String): String;
Begin
Result := s1 + ' ' + IntToStr(s2) + ' ' + IntToStr(s3) + ' ' + IntToStr(s4) + ' - OK!';
S5 := s5 + ' ' + result + ' - OK2!';
End;

Procedure MyWriteln(Const s: String);
Begin
Form1.Memo2.Lines.Add(s);
End;

Function MyReadln(Const question: String): String;
Begin
Result := InputBox(question, '', '');
End;

Procedure TForm1.PSScriptCompile(Sender: TPSScript);
Begin
Sender.AddFunction(@MyWriteln, 'procedure Writeln(s: string);');
Sender.AddFunction(@MyReadln, 'function Readln(question: string): string;');
Sender.AddFunction(@ImportTest, 'function ImportTest(S1: string; s2: Longint; s3: Byte; s4: word; var s5: string): string;');
Sender.AddRegisteredVariable('Application', 'TApplication');
Sender.AddRegisteredVariable('Self', 'TForm');
Sender.AddRegisteredVariable('Memo1', 'TMemo');
Sender.AddRegisteredVariable('Memo2', 'TMemo');
Sender.AddMethod(Self, @TForm1.ShowNewMessage, 'procedure ShowNewMessage (Const Message: String);');
End;

Procedure TForm1.Compile1Click(Sender: TObject);
Procedure OutputMessages;
Var
l : Longint;
b : Boolean;
Begin
b := False;

For l := 0 To PSScript.CompilerMessageCount - 1 Do
Begin
Memo2.Lines.Add('Compiler: ' + PSScript.CompilerErrorToStr(l));
If (Not b) And (PSScript.CompilerMessages[l] Is TIFPSPascalCompilerError) Then
Begin
b := True;
Memo1.SelStart := PSScript.CompilerMessages[l].Pos;
End;
End;
End;
Begin
Memo2.Lines.Clear;
PSScript.Script.Assign(Memo1.Lines);
Memo2.Lines.Add('Compiling');
If PSScript.Compile Then
Begin
OutputMessages;
Memo2.Lines.Add('Compiled succesfully');
If Not PSScript.Execute Then
Begin
Memo1.SelStart := PSScript.ExecErrorPosition;
Memo2.Lines.Add(PSScript.ExecErrorToString + ' at ' + Inttostr(PSScript.ExecErrorProcNo) + '.' + Inttostr(PSScript.ExecErrorByteCodePosition));
End
Else
Memo2.Lines.Add('Succesfully executed');
End
Else
Begin
OutputMessages;
Memo2.Lines.Add('Compiling failed');
End;
End;

Procedure TForm1.PSScriptExecute(Sender: TPSScript);
Begin
PSScript.SetVarToInstance('APPLICATION', Application);
PSScript.SetVarToInstance('SELF', Self);
PSScript.SetVarToInstance('MEMO1', Memo1);
PSScript.SetVarToInstance('MEMO2', Memo2);
End;

Procedure TForm1.PSScriptVerifyProc(Sender: TPSScript; Proc: TPSInternalProcedure; Const Decl: String; Var Error: Boolean);
Begin
If Proc.Name = 'TESTFUNCTION' Then
Begin
If Not ExportCheck(Sender.Comp, Proc, [btS32, btDouble, btString], [pmIn, pmIn]) Then
Begin
Sender.Comp.MakeError('', ecCustomError, 'Function header for TestFunction does Not match.');
Error := True;
End
Else
Begin
Error := False;
End;
End
Else
Error := False;

If Proc.Name = 'TESTFUNCTION' Then
Begin
If Not ExportCheck(Sender.Comp, Proc, [btS32, btDouble, btString], [pmIn, pmIn]) Then
Begin
Sender.Comp.MakeError('', ecCustomError, 'Function header for TestFunction does Not match.');
Error := True;
End
Else
Begin
Error := False;
End;
End
Else
Error := False;
End;

Procedure TForm1.mniN22341Click(Sender: TObject);
Var
Meth : TTestFunction;
Begin
Meth := TTestFunction(PSScript.GetProcMethod('TESTFUNCTION'));
If @Meth = Nil Then
Raise Exception.Create('Unable to call TestFunction');
ShowMessage('Result: ' + IntToStr(Meth(pi, DateTimeToStr(Now))));
End;

End.

 

Program test;
var
dm:Variant;
begin
dm :=CreateOleObject('dm.dmsoft');
dm.moveto(0,0);
end.