奇技淫巧之Delphi和JavaScript互通

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;

end.