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;