关于TChrome中加载JS与delphi交互问题
我这里直接给他代码，是转载的大神的，具体地址忘了。
(* * NeuglsWorkStudio * HTML Interface Javascript Extendtion * This unit implmented TNCJsExtented which used for extend the capablity of * javascript. * * Author : Neugls * Create time: 4/27/2011 * * Thanks for : Henri Gourvest * * * * * *)unit VCL.JSExtented;interfaceuses SysUtils, Classes,ceflib,Rtti,cefvcl;const csErrorParameters ='Error Parameters'; csHaveNoThisMember ='Have no member'; csChromiumCouldNotBeNil ='Chromium could not be nil, please first set the Chromium property';type {} TVCLJsExtended = class(TComponent) type TANameType=(ntMethod,ntField,ntProperty); {Inner class} TNCJSHandle=class(TCefv8HandlerOwn) private FContainer:TVCLJsExtended; protected function Execute(const name: ustring; const obj: ICefv8Value; const arguments: TCefv8ValueArray; var retval: ICefv8Value; var exception: ustring): Boolean; override; procedure JsCallMethod(Method:TRttiMethod;out ReturnVal:ICefv8Value; const Param:TCefv8ValueArray);overload; procedure JsCallMethod(Method:TRttiMethod;out ReturnVal:ICefv8Value);overload; function MethodParamLength(Mn:string):Integer; public constructor Create(Container:TVCLJsExtended); end; private FProcessObject:TObject; FJsHandle:TNCJSHandle; FTypeInfo:Pointer; FCustomChromium:TChromium; FFrame:ICefFrame; public Frame:ICefFrame{ read FFrame write FFrame}; property ProcessObject:TObject read FProcessObject; property ATypeInfo:Pointer read FTypeInfo; procedure SetProcessObject(value:TObject;ATypeInfo:Pointer); Procedure ExecuteJavaScript(const jsCode, scriptUrl: string; startLine: Integer);overload; Procedure ExecuteJavaScript(const jsCode:string);overload; constructor create(AOwner:TComponent);override; property Chromium:TChromium read FCustomChromium write FCustomChromium; end; TVCLNcJsExtended = class(TVCLJsExtended) published property Chromium; end; TNCWebBrowser=class(TChromium) end;procedure Register;implementationuses TypInfo;procedure Register;begin RegisterComponents('NwControls', [TVCLNcJsExtended]); RegisterComponents('NwControls', [TChromium]);end;{ TVCLJsExtended }constructor TVCLJsExtended.create(AOwner:TComponent);begin inherited create(AOwner); FProcessObject:=nil; FJsHandle:=TNCJSHandle.Create(Self);end;procedure TVCLJsExtended.ExecuteJavaScript(const jsCode, scriptUrl: string; startLine: Integer);begin if not Assigned(FCustomChromium) then begin raise Exception.Create(csChromiumCouldNotBeNil); Exit; end; FCustomChromium.Browser.MainFrame.ExecuteJavaScript(jsCode,scriptUrl,startLine);end;procedure TVCLJsExtended.ExecuteJavaScript(const jsCode:string);begin ExecuteJavaScript(jsCode,'',0);end;procedure TVCLJsExtended.SetProcessObject(value: TObject;ATypeInfo:Pointer);var RttiContext:TRttiContext; RttiType:TRttiType; RM:TRttiMethod; RP:TRttiProperty; RF:TRttiField; JsStr,name:String; I:Integer;begin { 根据object所提供的方法属性生成js字符串，希望注册. } FProcessObject:=value; FTypeInfo:=ATypeInfo; RttiType:=RttiContext.GetType(FTypeInfo); name:=RttiType.Name; JsStr:=Format('var %s;',[name]); JsStr:=Format('%s if(!%s) %s={};',[JsStr,name,name]); {Process method} for RM in RttiType.GetMethods do begin JsStr:=JsStr+Format(#$A#$D' native function %s(',[RM.Name]); if Length(RM.GetParameters)=0 then JsStr:=Format('%s);',[JsStr]) else begin for I := 0 to Length(RM.GetParameters)-2 do JsStr:=Format('%s %s,',[JsStr,chr(ord('A')+I)]); I:=Length(RM.GetParameters)-1; JsStr:=Format('%s %s);',[JsStr,chr(ord('A')+I)]); end; end; {Process Field} for RF in RttiType.GetFields do begin JsStr:=Format('%s'#$A#$D' var %s;',[JsStr,RF.Name]); case RF.FieldType.TypeKind of tkUnknown: ; tkInteger: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsInteger]); tkChar: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]); tkEnumeration: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsInteger]); tkFloat: JsStr:=Format('%s'#$A#$D' %s=%f;',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsExtended]); tkString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]); tkSet: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsInteger]); tkClass:{support later} JsStr:=Format('%s'#$A#$D' %s={};',[JsStr,RF.Name]); tkMethod: ; tkWChar: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]); tkLString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]); tkWString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]); tkVariant: ; tkArray: ; tkRecord: ; tkInterface: ; tkInt64: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsInteger]); tkDynArray: ; tkUString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RF.Name,RF.GetValue(FProcessObject).AsString]); tkClassRef: ; tkPointer: ; tkProcedure: ; end; end; {Process property} for RP in RttiType.GetProperties do begin JsStr:=Format('%s'#$A#$D' var %s;',[JsStr,RP.Name]); case RF.FieldType.TypeKind of tkUnknown: ; tkInteger: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsInteger]); tkChar: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]); tkEnumeration: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsInteger]); tkFloat: JsStr:=Format('%s'#$A#$D' %s=%f;',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsExtended]); tkString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]); tkSet: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsInteger]); tkClass:{support later} JsStr:=Format('%s'#$A#$D' %s={};',[JsStr,RP.Name]); tkMethod: ; tkWChar: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]); tkLString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]); tkWString: JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]); tkVariant: ; tkArray: ; tkRecord: ; tkInterface: ; tkInt64: JsStr:=Format('%s'#$A#$D' %s=%d;',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsInteger]); tkDynArray: ; tkUString: if not RP.GetValue(FProcessObject).IsObject then JsStr:=Format('%s'#$A#$D' %s="%s";',[JsStr,RP.Name,RP.GetValue(FProcessObject).AsString]); tkClassRef: ; tkPointer: ; tkProcedure: ; end; end; if not CefRegisterExtension(RttiType.Name,JsStr,FJsHandle) then Raise Exception.Create('Register JavaScript Extension Error');end;{ TVCLJsExtended.TNCJSHandle }constructor TVCLJsExtended.TNCJSHandle.Create( Container: TVCLJsExtended);begin inherited Create; FContainer:=Container;end;function TVCLJsExtended.TNCJSHandle.Execute(const name: ustring; const obj: ICefv8Value; const arguments: TCefv8ValueArray; var retval: ICefv8Value; var exception: ustring): Boolean;var RttiContext:TRttiContext; rm:TRttiMember; M:TRttiMethod; F:TRttiField; P:TRttiProperty; A:TRttiArrayType; nameType:TANameTYpe; o:TObject; n:string; function ObjectHaveName(const AObject:TObject; const name:String;out isMethod:TANameTYpe; out mb:TRttiMember):Boolean; var RttiType:TRttiType; RM:TRttiMethod; RP:TRttiProperty; RF:TRttiField; begin Result:=false; RttiType:=RttiContext.GetType(FContainer.FTypeInfo); for RM in RttiType.GetMethods do begin if CompareText(RM.Name,name)=0 then begin isMethod:=ntMethod; mb:=RM; Exit(True); end; end; for RP in RttiType.GetProperties do begin if CompareText(RP.Name,name)=0 then begin isMethod:=ntProperty; mb:=RP; Exit(True); end; end; for RF in RttiType.GetFields do begin if CompareText(RF.Name,name)=0 then begin isMethod:=ntField; mb:=RF; Exit(True); end; end; end;begin Result:=true; O:=FContainer.ProcessObject; n:=name; if not ObjectHaveName(O,name,nameType,rm) then begin exception:=csHaveNoThisMember; Exit(False); end; case nameType of ntMethod: begin M:=rm as TRttiMethod; //Assert(M.MethodKind<>mkFunction); if Length(M.GetParameters)>0 then begin if (Length(arguments)>0) and (Length(arguments)=Length(M.GetParameters)) then begin JsCallMethod(M,retval,arguments); end else begin exception:=csErrorParameters; Exit(False); end; end else begin JsCallMethod(M,retval); end; end; ntField: begin F:=rm as TRttiField; case F.FieldType.TypeKind of tkUnknown: ; tkInteger: retval:=TCefv8ValueRef.CreateInt(F.GetValue(FContainer.ProcessObject).AsInteger); tkChar: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString); tkEnumeration: retval:=TCefv8ValueRef.CreateInt(F.GetValue(FContainer.ProcessObject).AsInteger); tkFloat: retval:=TCefv8ValueRef.CreateDouble(F.GetValue(FContainer.ProcessObject).AsExtended); tkString: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString); tkSet: retval:=TCefv8ValueRef.CreateInt(F.GetValue(FContainer.ProcessObject).AsInteger); tkClass: ;//retval:=TCefv8ValueRef.CreateObject(F.GetValue(FContainer.ProcessObject).AsObject); tkMethod: ; tkWChar: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString); tkLString: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString); tkWString: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString); tkVariant: ; tkArray: begin { retval:=TCefv8ValueRef.CreateArray; A:=F.FieldType as TRttiArrayType; //support only one demision array if A.DimensionCount=1 then for I := 0 to A.TotalElementCount do begin case A.ElementType.TypeKind of tkUnknown: retval.SetValueByIndex(I,TCefv8ValueRef.create()); tkInteger: ; tkChar: ; tkEnumeration: ; tkFloat: ; tkString: ; tkSet: ; tkClass: ; tkMethod: ; tkWChar: ; tkLString: ; tkWString: ; tkVariant: ; tkArray: ; tkRecord: ; tkInterface: ; tkInt64: ; tkDynArray: ; tkUString: ; tkClassRef: ; tkPointer: ; tkProcedure: ; end; retval.SetValueByIndex(I,TCefv8ValueRef.create) end; retval.SetValueByIndex() end;; tkRecord: ; tkInterface: ; tkInt64: retval:=TCefv8ValueRef.CreateInt(F.GetValue(FContainer.ProcessObject).AsInteger); tkDynArray: ; tkUString: retval:=TCefv8ValueRef.CreateString(F.GetValue(FContainer.ProcessObject).AsString); tkClassRef: ; tkPointer: retval:=TCefv8ValueRef.CreateInt(F.GetValue(FContainer.ProcessObject).AsInteger); tkProcedure: ; } end; end; end; ntProperty: begin P:=rm as TRttiProperty; case P.PropertyType.TypeKind of tkUnknown: ; tkInteger: retval:=TCefv8ValueRef.CreateInt(p.GetValue(FContainer.ProcessObject).AsInteger); tkChar: retval:=TCefv8ValueRef.CreateString(p.GetValue(FContainer.ProcessObject).AsString); tkEnumeration: retval:=TCefv8ValueRef.CreateInt(p.GetValue(FContainer.ProcessObject).AsInteger); tkFloat: retval:=TCefv8ValueRef.CreateDouble(p.GetValue(FContainer.ProcessObject).AsExtended); tkString: retval:=TCefv8ValueRef.CreateString(p.GetValue(FContainer.ProcessObject).AsString); tkSet: retval:=TCefv8ValueRef.CreateInt(p.GetValue(FContainer.ProcessObject).AsInteger); tkClass: ;//retval:=TCefv8ValueRef.CreateObject(p.GetValue(FContainer.ProcessObject).AsObject); tkMethod: ; tkWChar: retval:=TCefv8ValueRef.CreateString(p.GetValue(FContainer.ProcessObject).AsString); tkLString: retval:=TCefv8ValueRef.CreateString(p.GetValue(FContainer.ProcessObject).AsString); tkWString: retval:=TCefv8ValueRef.CreateString(p.GetValue(FContainer.ProcessObject).AsString); tkVariant: ; tkArray:; end; end; end;end;procedure TVCLJsExtended.TNCJSHandle.JsCallMethod(Method: TRttiMethod; out ReturnVal: ICefv8Value; const Param: TCefv8ValueArray);var VA:array of TValue; I:Integer; rva:TValue; AInstance:TObject;begin if Param<>nil then begin SetLength(VA,Length(Param)); for I := 0 to Length(Method.GetParameters)-1 do begin if Param[I].IsBool then VA[I]:=TValue.From<Boolean>(Param[I].GetBoolValue); if Param[I].IsInt then begin VA[I]:=TValue.From<Integer>(Param[I].GetIntValue); Continue; end; if Param[I].IsDouble then begin VA[I]:=TValue.From<Double>(Param[I].GetDoubleValue); Continue; end; if Param[I].IsString then VA[I]:=TValue.From<String>(Param[I].GetStringValue); if Param[I].IsObject then {VA[I].AsObject:=Param[I].get}; //if Param[I].is then end; end else ;//VA:=nil; AInstance:=FContainer.ProcessObject; Rva:=Method.Invoke(AInstance,VA); case rva.Kind of tkUnknown: ; tkInteger: ReturnVal:=TCefv8ValueRef.CreateInt(rva.AsInteger); tkChar: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString); tkEnumeration: ReturnVal:=TCefv8ValueRef.CreateInt(rva.AsOrdinal); tkFloat: ReturnVal:=TCefv8ValueRef.CreateDouble(rva.AsExtended); tkString: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString); tkSet: ReturnVal:=TCefv8ValueRef.CreateInt(rva.AsInteger); tkClass: ;//ReturnVal:=TCefv8ValueRef.CreateObject(rva.AsObject); tkMethod: ; tkWChar: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString); tkLString: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString); tkWString: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString); tkVariant: ; tkArray:; tkRecord: ; tkInterface: ; tkInt64: ReturnVal:=TCefv8ValueRef.CreateInt(rva.AsInteger); tkDynArray: ; tkUString: ReturnVal:=TCefv8ValueRef.CreateString(rva.AsString); tkClassRef: ; tkPointer: ; tkProcedure: ; end;end;procedure TVCLJsExtended.TNCJSHandle.JsCallMethod(Method: TRttiMethod; out ReturnVal: ICefv8Value);begin JsCallMethod(Method,ReturnVal,nil);end;function TVCLJsExtended.TNCJSHandle.MethodParamLength(Mn: string): Integer;var Rtx:TRttiContext; M:TRttiMethod; RT:TRttiType;begin RT:=Rtx.GetType(FContainer.FTypeInfo); M:=Rt.GetMethod(Mn); Result:=Length(M.GetParameters);end;end. |
这是一个控件，他的功能是把delphi函数预注册到程序环境中，这样，在本程序内的所有chrome控件，都可以通过js调用到delphi函数，不过请注意，最好不要用到boolean类型的变量，这样会导致js调用不到delphi。
