我这里直接给他代码，是转载的大神的，具体地址忘了。
(*
* 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。
628
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
