奇技淫巧之Delphi和JavaScript互通

http://www.raysoftware.cn/?p=305

Delphi2010以后增加了新的RTTI信息,也就是通过RTTI可以在运行时获取/调用对象的公开成员或者函数.

ScriptControl可以添加外部的对象,这个对象是个IDispatch接口,脚本调用的时候实际上是调用IDispatch的Invoke方法.

那么我们只要实现了IDispatch的Invoke方法,在里面通过RTTI再转而调用Delphi对象的Public方法即可.通过这个可以代理任何Delphi的对象.

仅仅调用Delphi对象似乎还不够完美,对象事件如果能关联到脚本的函数就更好了.那好,封装一个事件代理的类就可以.

例子如下:

procedure TForm1.FormCreate(Sender: TObject);

begin

Fscript := CreateScriptControl();

// 把Form1当成一个对象添加到Script中

Fscript.AddObject(Self.Name, SA(Self), true);

Fscript.AddCode('function Form1_OnMouseMove(Sender, shift, x, y)' //

+ '{' // 在JS里面直接调用Form1上的任何Public的东西就都可以了,JS里面几乎没有类型的概念.事件的参数随便.计算也随便

+ 'Form1.Button1.Caption = "x:"+x+";"+"y:"+y +";" + "shift:" + shift;' //

+ '}' //

+ 'function Button1_Click(Sender)' //

+ '{' //调用Delphi对象的方法

+ 'Form1.SetBounds(0,0,800,480);' //

+ '}' //

);

//关联Delphi的事件到JS的函数

Self.OnMouseMove := TEventDispatch.Create<TMouseMoveEvent>(Self, Fscript,

'Form1_OnMouseMove');

Button1.OnClick := TEventDispatch.Create<TNotifyEvent>(Button1, Fscript,

'Button1_Click');

end;

看上去很爽吧.

不过这个仅供我自己玩的,代码实现的比较毛糙,也没有经过严格的测试,甚至自己也没从头到尾再检查一次.如果有需要实用的朋友最好谨慎,肯定有细节问题要解决.

另外这个ScriptControl仅仅有32位的,在64位Windows上的system32里面并没有这个DLL,仅仅在SysWow64中才有.也就是说如果你要开发64位Windows程序就不能用了.当然如果是在64位Windows中运行的32位程序则没问题.

下面是代码,写的比较丑.

{

让Delphi使用windows自带的scriptcontrol,在javascript中可以调用delphi的对象,

并且可以使用事件.

wr960204武稀松 2013

}

unit ScriptObjectUtilsWithRTTI;

interface

{

是否使用外部的MSScriptControl_TLB单元.我把这个单元的接口声明都放在后面了,

可以避免引入ActiveX等单元

如果觉得我的声明太旧或者有问题,可以打开这个开关,使用外部自己Import生成的单元

}

{ .$DEFINE Use_External_TLB }

{ 这个开关是使用LoadLibrary方式加载COM DLL,也就及时COM组件没有注册也可以创建COM对象 }

{$DEFINE COMOBJ_FROMDLL}

uses

{$IFDEF Use_External_TLB}

MSScriptControl_TLB,

{$ENDIF}

System.ObjAuto,

System.Classes, System.RTTI, System.Variants,

Winapi.Windows, Winapi.ActiveX, System.TypInfo;

type

{$REGION 'MSScriptControl_TLB'}

{$IFDEF Use_External_TLB}

IScriptControl = MSScriptControl_TLB.IScriptControl;

{$ELSE}

ScriptControlStates = TOleEnum;

IScriptModuleCollection = IDispatch;

IScriptError = IDispatch;

IScriptProcedureCollection = IDispatch;

IScriptControl = interface(IDispatch)

['{0E59F1D3-1FBE-11D0-8FF2-00A0D10038BC}']

function Get_Language: WideString; safecall;

procedure Set_Language(const pbstrLanguage: WideString); safecall;

function Get_State: ScriptControlStates; safecall;

procedure Set_State(pssState: ScriptControlStates); safecall;

procedure Set_SitehWnd(phwnd: Integer); safecall;

function Get_SitehWnd: Integer; safecall;

function Get_Timeout: Integer; safecall;

procedure Set_Timeout(plMilleseconds: Integer); safecall;

function Get_AllowUI: WordBool; safecall;

procedure Set_AllowUI(pfAllowUI: WordBool); safecall;

function Get_UseSafeSubset: WordBool; safecall;

procedure Set_UseSafeSubset(pfUseSafeSubset: WordBool); safecall;

function Get_Modules: IScriptModuleCollection; safecall;

function Get_Error: IScriptError; safecall;

function Get_CodeObject: IDispatch; safecall;

function Get_Procedures: IScriptProcedureCollection; safecall;

procedure _AboutBox; safecall;

procedure AddObject(const Name: WideString; const Object_: IDispatch;

AddMembers: WordBool); safecall;

procedure Reset; safecall;

procedure AddCode(const Code: WideString); safecall;

function Eval(const Expression: WideString): OleVariant; safecall;

procedure ExecuteStatement(const Statement: WideString); safecall;

function Run(const ProcedureName: WideString; var Parameters: PSafeArray)

: OleVariant; safecall;

property Language: WideString read Get_Language write Set_Language;

property State: ScriptControlStates read Get_State write Set_State;

property SitehWnd: Integer read Get_SitehWnd write Set_SitehWnd;

property Timeout: Integer read Get_Timeout write Set_Timeout;

property AllowUI: WordBool read Get_AllowUI write Set_AllowUI;

property UseSafeSubset: WordBool read Get_UseSafeSubset

write Set_UseSafeSubset;

property Modules: IScriptModuleCollection read Get_Modules;

property Error: IScriptError read Get_Error;

property CodeObject: IDispatch read Get_CodeObject;

property Procedures: IScriptProcedureCollection read Get_Procedures;

end;

{$ENDIF}

{$ENDREGION 'MSScriptControl_TLB'}

{ 事件代理的泛型类,可以把Delphi的事件映射到Javascript的函数上.

注意,这是一个TComponent的派生类.如果不指定Ownder的话要手工释放的.

}

TEventDispatch = class(TComponent)

private

FScriptControl: IScriptControl;

FScriptFuncName: string;

FInternalDispatcher: TMethod;

FRttiContext: TRttiContext;

FRttiType: TRttiMethodType;

procedure InternalInvoke(Params: PParameters; StackSize: Integer);

function ValueToVariant(Value: TValue): Variant;

constructor Create(AOwner: TComponent; ATTypeInfo: PTypeInfo);

reintroduce; overload;

public

class function Create<T>(AOwner: TComponent; ScriptControl: IScriptControl;

ScriptFuncName: String): T; reintroduce; overload;

destructor Destroy; override;

end;

{ 很普通,创建一个MSWindows自带的ScriptControl实例,默认脚本是Javascript }

function CreateScriptControl(ScriptName: String = 'javascript'): IScriptControl;

{ 创建对象的IDispatch的代理, Owned表示这个IDispatch拥有代理对象的生杀大权,当代理的IDispatch

释放的时候这个Obj也会被释放掉 }

function SA(Obj: TObject; Owned: Boolean): IDispatch; overload;

{ 创建对象的IDispatch的代理 }

function SA(Obj: TObject): IDispatch; overload;

implementation

uses

{$IFNDEF COMOBJ_FROMDLL}

System.Win.ComObj,

{$ENDIF}

System.SysUtils;

function CreateScriptControl(ScriptName: String): IScriptControl;

const

CLASS_ScriptControl: TGUID = '{0E59F1D5-1FBE-11D0-8FF2-00A0D10038BC}';

{$IFDEF COMOBJ_FROMDLL}

MSSCRIPTMODULE = 'msscript.ocx';

var

DllGetClassObject: function(const clsid, IID: TGUID; var Obj)

: HRESULT; stdcall;

ClassFactory: IClassFactory;

hLibInst: HMODULE;

hr: HRESULT;

begin

Result := nil;

hLibInst := GetModuleHandle(MSSCRIPTMODULE);

if hLibInst = 0 then

hLibInst := LoadLibrary(MSSCRIPTMODULE);

if hLibInst = 0 then

Exit;

DllGetClassObject := GetProcAddress(hLibInst, 'DllGetClassObject');

if Assigned(DllGetClassObject) then

begin

hr := DllGetClassObject(CLASS_ScriptControl, IClassFactory, ClassFactory);

if hr = S_OK then

begin

hr := ClassFactory.CreateInstance(nil, IScriptControl, Result);

if (hr = S_OK) and (Result <> nil) then

Result.Language := ScriptName;

end;

end;

end;

{$ELSE}

begin

Result := CreateComObject(CLASS_ScriptControl) as IScriptControl;

if Result <> nil then

Result.Language := ScriptName;

end;

{$ENDIF}

type

TDispatchKind = (dkMethod, dkProperty, dkSubComponent);

TDispatchInfo = record

Instance: TObject;

case Kind: TDispatchKind of

dkMethod:

(MethodInfo: TRttiMethod);

dkProperty:

(PropInfo: TRttiProperty);

dkSubComponent:

(ComponentInfo: NativeInt);

end;

TDispatchInfos = array of TDispatchInfo;

{

IDispatch代理类.通过RTTI可以把Delphi对象的成员/属性/函数映射给IDispatch.

而且忽略调用协议.

}

TScriptObjectAdapter = class(TInterfacedObject, IDispatch)

private

//

FRttiContext: TRttiContext;

FRttiType: TRttiType;

FDispatchInfoCount: Integer;

FDispatchInfos: TDispatchInfos;

FComponentNames: TStrings;

FInstance: TObject;

FOwned: Boolean;

function AllocDispID(AKind: TDispatchKind; Value: Pointer;

AInstance: TObject): TDispID;

protected

property Instance: TObject read FInstance;

public

{ IDispatch }

function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount: Integer;

LocaleID: Integer; DispIDs: Pointer): HRESULT; virtual; stdcall;

function GetTypeInfo(Index: Integer; LocaleID: Integer; out TypeInfo)

: HRESULT; stdcall;

function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;

function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;

Flags: Word; var Params; VarResult: Pointer; ExcepInfo: Pointer;

ArgErr: Pointer): HRESULT; virtual; stdcall;

public

constructor Create(Instance: TObject; Owned: Boolean = False);

destructor Destroy; override;

end;

function SA(Obj: TObject; Owned: Boolean): IDispatch;

begin

Result := TScriptObjectAdapter.Create(Obj, Owned);

end;

function SA(Obj: TObject): IDispatch;

begin

Result := TScriptObjectAdapter.Create(Obj, False);

end;

const

ofDispIDOffset = 100;

{ TScriptObjectAdapter }

function TScriptObjectAdapter.AllocDispID(AKind: TDispatchKind; Value: Pointer;

AInstance: TObject): TDispID;

var

I: Integer;

dispatchInfo: TDispatchInfo;

begin

for I := FDispatchInfoCount - 1 downto 0 do

with FDispatchInfos[I] do

if (Kind = AKind) and (MethodInfo = Value) then

begin

// Already have a dispid for this methodinfo

Result := ofDispIDOffset + I;

Exit;

end;

if FDispatchInfoCount = Length(FDispatchInfos) then

SetLength(FDispatchInfos, Length(FDispatchInfos) + 10);

Result := ofDispIDOffset + FDispatchInfoCount;

with dispatchInfo do

begin

Instance := AInstance;

Kind := AKind;

MethodInfo := Value;

end;

FDispatchInfos[FDispatchInfoCount] := dispatchInfo;

Inc(FDispatchInfoCount);

end;

constructor TScriptObjectAdapter.Create(Instance: TObject; Owned: Boolean);

begin

inherited Create;

FComponentNames := TStringList.Create;

FInstance := Instance;

FOwned := Owned;

FRttiContext := TRttiContext.Create;

FRttiType := FRttiContext.GetType(FInstance.ClassType);

end;

destructor TScriptObjectAdapter.Destroy;

begin

if FOwned then

FInstance.Free;

FRttiContext.Free;

FComponentNames.Free;

inherited Destroy;

end;

function TScriptObjectAdapter.GetIDsOfNames(const IID: TGUID; Names: Pointer;

NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;

type

PNames = ^TNames;

TNames = array [0 .. 100] of POleStr;

PDispIDs = ^TDispIDs;

TDispIDs = array [0 .. 100] of Cardinal;

var

Name: String;

MethodInfo: TRttiMethod;

PropertInfo: TRttiProperty;

ComponentInfo: TComponent;

lDispId: TDispID;

begin

Result := S_OK;

lDispId := -1;

Name := WideCharToString(PNames(Names)^[0]);

MethodInfo := FRttiType.GetMethod(Name);

// MethodInfo.Invoke(FInstance, ['']);

if MethodInfo <> nil then

begin

lDispId := AllocDispID(dkMethod, MethodInfo, FInstance);

end

else

begin

PropertInfo := FRttiType.GetProperty(Name);

if PropertInfo <> nil then

begin

lDispId := AllocDispID(dkProperty, PropertInfo, FInstance);

end

else if FInstance is TComponent then

begin

ComponentInfo := TComponent(FInstance).FindComponent(Name);

if ComponentInfo <> nil then

begin

lDispId := AllocDispID(dkSubComponent, Pointer(FComponentNames.Add(Name)

), FInstance);

end;

end;

end;

if lDispId >= ofDispIDOffset then

begin

Result := S_OK;

PDispIDs(DispIDs)^[0] := lDispId;

end;

end;

function TScriptObjectAdapter.GetTypeInfo(Index, LocaleID: Integer;

out TypeInfo): HRESULT;

begin

Result := E_NOTIMPL;

end;

function TScriptObjectAdapter.GetTypeInfoCount(out Count: Integer): HRESULT;

begin

Result := E_NOTIMPL;

end;

function TScriptObjectAdapter.Invoke(DispID: Integer; const IID: TGUID;

LocaleID: Integer; Flags: Word; var Params;

VarResult, ExcepInfo, ArgErr: Pointer): HRESULT;

type

PVariantArray = ^TVariantArray;

TVariantArray = array [0 .. 65535] of Variant;

PIntegerArray = ^TIntegerArray;

TIntegerArray = array [0 .. 65535] of Integer;

var

Parms: PDispParams;

TempRet: Variant;

dispatchInfo: TDispatchInfo;

lParams: TArray<TValue>;

paramInfos: TArray<TRttiParameter>;

I: Integer;

component: TComponent;

propertyValue: TValue;

_SetValue: NativeInt;

tmpv: Variant;

begin

Result := S_OK;

Parms := @Params;

try

if VarResult = nil then

VarResult := @TempRet;

if (DispID - ofDispIDOffset >= 0) and

(DispID - ofDispIDOffset < FDispatchInfoCount) then

begin

dispatchInfo := FDispatchInfos[DispID - ofDispIDOffset];

case dispatchInfo.Kind of

dkProperty:

begin

if Flags and (DISPATCH_PROPERTYPUTREF or DISPATCH_PROPERTYPUT) <> 0

then

if (Parms.cNamedArgs <> 1) or

(PIntegerArray(Parms.rgdispidNamedArgs)^[0] <>

DISPID_PROPERTYPUT) then

Result := DISP_E_MEMBERNOTFOUND

else

begin

propertyValue := TValue.Empty;

case dispatchInfo.PropInfo.PropertyType.Handle^.Kind of

tkInt64, tkInteger:

propertyValue :=

TValue.FromOrdinal

(dispatchInfo.PropInfo.PropertyType.Handle,

PVariantArray(Parms.rgvarg)^[0]);

tkFloat:

propertyValue := TValue.From<Extended>

(PVariantArray(Parms.rgvarg)^[0]);

tkString, tkUString, tkLString, tkWString:

propertyValue :=

TValue.From<String>(PVariantArray(Parms.rgvarg)^[0]);

tkSet:

begin

_SetValue := PVariantArray(Parms.rgvarg)^[0];

TValue.Make(_SetValue,

dispatchInfo.PropInfo.PropertyType.Handle,

propertyValue);

end;

else

propertyValue :=

TValue.FromVariant(PVariantArray(Parms.rgvarg)^[0]);

end;

dispatchInfo.PropInfo.SetValue(dispatchInfo.Instance,

propertyValue);

end

else if Parms.cArgs <> 0 then

Result := DISP_E_BADPARAMCOUNT

else if dispatchInfo.PropInfo.PropertyType.Handle^.Kind = tkClass

then

POleVariant(VarResult)^ :=

SA(dispatchInfo.PropInfo.GetValue(dispatchInfo.Instance)

.AsObject()) as IDispatch

else

POleVariant(VarResult)^ := dispatchInfo.PropInfo.GetValue

(dispatchInfo.Instance).AsVariant;

end;

dkMethod:

begin

paramInfos := dispatchInfo.MethodInfo.GetParameters;

SetLength(lParams, Length(paramInfos));

for I := Low(paramInfos) to High(paramInfos) do

if I < Parms.cArgs then

begin

//因为IDispatch是COM对象,一般是stdcall或者safecall,参数是由右到左传递的

tmpv := PVariantArray(Parms.rgvarg)^[Parms.cArgs - 1 - I];

lParams[I] := TValue.FromVariant(tmpv);

end

else //不足的参数补空

begin

TValue.Make(0, paramInfos[I].ParamType.Handle, lParams[I]);

end;

if (dispatchInfo.MethodInfo.ReturnType <> nil) and

(dispatchInfo.MethodInfo.ReturnType.Handle^.Kind = tkClass) then

begin

POleVariant(VarResult)^ :=

SA(dispatchInfo.MethodInfo.Invoke(dispatchInfo.Instance,

lParams).AsObject()) as IDispatch;

end

else

begin

POleVariant(VarResult)^ := dispatchInfo.MethodInfo.Invoke

(dispatchInfo.Instance, lParams).AsVariant();

end;

end;

dkSubComponent:

begin

component := TComponent(dispatchInfo.Instance)

.FindComponent(FComponentNames[dispatchInfo.ComponentInfo]);

if component = nil then

Result := DISP_E_MEMBERNOTFOUND;

POleVariant(VarResult)^ := SA(component) as IDispatch;

end;

end;

end

else

Result := DISP_E_MEMBERNOTFOUND;

except

if ExcepInfo <> nil then

begin

FillChar(ExcepInfo^, SizeOf(TExcepInfo), 0);

with TExcepInfo(ExcepInfo^) do

begin

bstrSource := StringToOleStr(ClassName);

if ExceptObject is Exception then

bstrDescription := StringToOleStr(Exception(ExceptObject).Message);

scode := E_FAIL;

end;

end;

Result := DISP_E_EXCEPTION;

end;

end;

{ TEventDispatch<T> }

class function TEventDispatch.Create<T>(AOwner: TComponent;

ScriptControl: IScriptControl; ScriptFuncName: String): T;

type

PT = ^T;

var

ed: TEventDispatch;

begin

ed := TEventDispatch.Create(AOwner, TypeInfo(T));

ed.FScriptControl := ScriptControl;

ed.FScriptFuncName := ScriptFuncName;

Result := PT(@ed.FInternalDispatcher)^;

end;

constructor TEventDispatch.Create(AOwner: TComponent; ATTypeInfo: PTypeInfo);

var

LRttiType: TRttiType;

begin

FRttiContext := TRttiContext.Create;

LRttiType := FRttiContext.GetType(ATTypeInfo);

if not(LRttiType is TRttiMethodType) then

begin

raise Exception.Create('T only is Method(Member function)!');

end;

FRttiType := TRttiMethodType(LRttiType);

Inherited Create(AOwner);

FInternalDispatcher := CreateMethodPointer(InternalInvoke,

GetTypeData(FRttiType.Handle));

end;

destructor TEventDispatch.Destroy;

begin

ReleaseMethodPointer(FInternalDispatcher);

inherited Destroy;

end;

function TEventDispatch.ValueToVariant(Value: TValue): Variant;

var

_SetValue: Int64Rec;

begin

Result := EmptyParam;

case Value.TypeInfo^.Kind of

tkClass:

Result := SA(Value.AsObject);

tkInteger:

Result := Value.AsInteger;

tkString, tkLString, tkChar, tkUString:

Result := Value.AsString;

tkSet:

begin

Value.ExtractRawData(@_SetValue);

case Value.DataSize of

1:

Result := _SetValue.Bytes[0];

2:

Result := _SetValue.Words[0];

4:

Result := _SetValue.Cardinals[0];

8:

Result := Int64(_SetValue);

end;

end;

else

Result := Value.AsVariant;

end;

end;

function GetParamSize(TypeInfo: PTypeInfo): Integer;

begin

if TypeInfo = nil then

Exit(0);

case TypeInfo^.Kind of

tkInteger, tkEnumeration, tkChar, tkWChar, tkSet:

case GetTypeData(TypeInfo)^.OrdType of

otSByte, otUByte:

Exit(1);

otSWord, otUWord:

Exit(2);

otSLong, otULong:

Exit(4);

else

Exit(0);

end;

tkFloat:

case GetTypeData(TypeInfo)^.FloatType of

ftSingle:

Exit(4);

ftDouble:

Exit(8);

ftExtended:

Exit(SizeOf(Extended));

ftComp:

Exit(8);

ftCurr:

Exit(8);

else

Exit(0);

end;

tkClass, tkClassRef:

Exit(SizeOf(Pointer));

tkInterface:

Exit(-SizeOf(Pointer));

tkMethod:

Exit(SizeOf(TMethod));

tkInt64:

Exit(8);

tkDynArray, tkUString, tkLString, tkWString:

Exit(-SizeOf(Pointer));

tkString:

Exit(GetTypeData(TypeInfo)^.MaxLength + 1);

tkPointer:

Exit(SizeOf(Pointer));

tkRecord:

if IsManaged(TypeInfo) then

Exit(-GetTypeData(TypeInfo)^.RecSize)

else

Exit(GetTypeData(TypeInfo)^.RecSize);

tkArray:

Exit(GetTypeData(TypeInfo)^.ArrayData.Size);

tkVariant:

Exit(-SizeOf(Variant));

else

Exit(0);

end;

end;

procedure TEventDispatch.InternalInvoke(Params: PParameters;

StackSize: Integer);

var

lRttiParameters, tmp: TArray<TRttiParameter>;

lRttiParam: TRttiParameter;

lParamValues: TArray<TValue>;

I, ParamSize: Integer;

PStack: PByte;

test: string;

ParamIsByRef: Boolean;

RegParamIndexs: array [0 .. 2] of Byte;

RegParamIndex: Integer;

v, tmpv: Variant;

ParameterArray: PSafeArray;

begin

tmp := FRttiType.GetParameters;

SetLength(lRttiParameters, Length(tmp) + 1);

lRttiParameters[0] := nil;

for I := Low(tmp) to High(tmp) do

lRttiParameters[I + 1] := tmp[I];

SetLength(lParamValues, Length(lRttiParameters));

PStack := @Params.Stack[0];

if (FRttiType.CallingConvention = ccReg) then

begin

// 看那些参数用了寄存器传输

FillChar(RegParamIndexs, SizeOf(RegParamIndexs), -1);

RegParamIndexs[0] := 0;

RegParamIndex := 1;

for I := 1 to High(lRttiParameters) do

begin

lRttiParam := lRttiParameters[I];

ParamSize := GetParamSize(lRttiParam.ParamType.Handle);

ParamIsByRef := (lRttiParam <> nil) and

(([pfVar, pfConst, pfOut] * lRttiParam.Flags) <> []);

if ((ParamSize <= SizeOf(Pointer)) and

(not(lRttiParam.ParamType.Handle.Kind in [tkFloat]))) or (ParamIsByRef)

then

begin

RegParamIndexs[RegParamIndex] := I;

if (RegParamIndex = High(RegParamIndexs)) or (I = High(lRttiParameters))

then

Break;

Inc(RegParamIndex);

end;

end;

for I := High(lRttiParameters) downto Low(lRttiParameters) do

begin

lRttiParam := lRttiParameters[I];

if I = 0 then

TValue.Make(Params.EAXRegister, TypeInfo(TObject), lParamValues[I])

else

begin

ParamIsByRef := (lRttiParam <> nil) and

(([pfVar, pfConst, pfOut] * lRttiParam.Flags) <> []);

ParamSize := GetParamSize(lRttiParam.ParamType.Handle);

if (ParamSize < SizeOf(Pointer)) or (ParamIsByRef) then

ParamSize := SizeOf(Pointer);

if (I in [RegParamIndexs[0], RegParamIndexs[1], RegParamIndexs[2]]) then

begin

if ParamIsByRef then

begin

TValue.Make(Pointer(Params.Registers[RegParamIndex]),

lRttiParameters[I].ParamType.Handle, lParamValues[I]);

end

else

begin

TValue.Make(Params.Registers[RegParamIndex],

lRttiParameters[I].ParamType.Handle, lParamValues[I]);

end;

Dec(RegParamIndex);

end

else

begin

if ParamIsByRef then

TValue.Make(PPointer(PStack)^, lRttiParameters[I].ParamType.Handle,

lParamValues[I])

else

TValue.Make(PStack, lRttiParameters[I].ParamType.Handle,

lParamValues[I]);

Inc(PStack, ParamSize);

end;

end;

end;

end

else

begin

for I := Low(lRttiParameters) to High(lRttiParameters) do

begin

ParamIsByRef := (lRttiParameters[I] <> nil) and

(([pfVar, pfConst, pfOut] * lRttiParameters[I].Flags) <> []);

if I = 0 then

begin // Self

ParamSize := SizeOf(TObject);

TValue.Make(PStack, TypeInfo(TObject), lParamValues[I]);

end

else

begin

ParamSize := GetParamSize(lRttiParameters[I].ParamType.Handle);

if ParamSize < SizeOf(Pointer) then

ParamSize := SizeOf(Pointer);

// TValue.Make(PStack, lRttiParameters[I].ParamType.Handle,  lParamValues[I]);

if ParamIsByRef then

TValue.Make(PPointer(PStack)^, lRttiParameters[I].ParamType.Handle,

lParamValues[I])

else

TValue.Make(PStack, lRttiParameters[I].ParamType.Handle,

lParamValues[I]);

end;

Inc(PStack, ParamSize);

end;

end;

if (FScriptControl <> nil) and (FScriptFuncName <> '') then

begin

v := VarArrayCreate([0, Length(lParamValues) - 1], varVariant);

for I := 1 to Length(lParamValues) - 1 do

begin

test := lRttiParameters[I].Name;

tmpv := ValueToVariant(lParamValues[I]);

v[I - 1] := tmpv;

end;

ParameterArray := PSafeArray(TVarData(v).VArray);

FScriptControl.Run(FScriptFuncName, ParameterArray);

end;

end;