unit ScriptObjectUtilsWithRTTI;
interface
{$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'}
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;
function CreateScriptControl(ScriptName: String = 'javascript'): IScriptControl;
function SA(Obj: TObject; Owned: Boolean): IDispatch; overload;
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;
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
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;
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
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);
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
客服电话
APP下载
官方微信
请发表评论