奇技淫巧之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; 

 

转载于:https://www.cnblogs.com/blogpro/p/11452564.html

  • 0
    点赞
  • 0
    收藏
  • 0
    评论

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
©️2022 CSDN 皮肤主题:大白 设计师:CSDN官方博客 返回首页
评论
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、C币套餐、付费专栏及课程。

余额充值