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
;
|