posts - 16,  comments - 17,  trackbacks - 0

我这里直接给他代码,是转载的大神的,具体地址忘了。

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

interface

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

implementation
uses 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。

具体的用法可以在网上搜索下,我就里就不详细写了,毕竟是转载的。

posted on 2013-05-17 15:42 Bach 阅读(...) 评论(...) 编辑 收藏