P
pcspace
Unregistered / Unconfirmed
GUEST, unregistred user!
如何将Html源代码直接装载到TWebBrowser里面，而不是先将源代码保存为网页，再用navigate
打开！
打开！
P
pcspace
Unregistered / Unconfirmed
GUEST, unregistred user!
在窗体上放一个TMemo控件，一个TWebBrower控件，一个TButton控件，
在Memo里面写入正确的Html代码（包含JS、VBS特效），点击Button，在WebBrowser
里面可以显示出来效果就可以！Memo里面的代码就以 pcspace.myetang.com/JSTest.htm
的源代码为准！（我以前看过一个Demo程序，但是让我给搞丢了！可惜！）
如果谁做出来给我发到信箱里面： pcspace@sina.com
如果有控件，将控件一并发过来，如果有特殊说明，请写清楚！
在Memo里面写入正确的Html代码（包含JS、VBS特效），点击Button，在WebBrowser
里面可以显示出来效果就可以！Memo里面的代码就以 pcspace.myetang.com/JSTest.htm
的源代码为准！（我以前看过一个Demo程序，但是让我给搞丢了！可惜！）
如果谁做出来给我发到信箱里面： pcspace@sina.com
如果有控件，将控件一并发过来，如果有特殊说明，请写清楚！
P
pcspace
Unregistered / Unconfirmed
GUEST, unregistred user!
还没有人帮忙吗！！！
A
adrich
Unregistered / Unconfirmed
GUEST, unregistred user!
webbrowser1.navigate('http://www.delphibbs.com');
P
pcspace
Unregistered / Unconfirmed
GUEST, unregistred user!
adrich:
如果真的这么简单，我就不用提问了！
我得意思是：
将HTML代码直接装载到TWEBBROWSER里面！
如果真的这么简单，我就不用提问了！
我得意思是：
将HTML代码直接装载到TWEBBROWSER里面！
爱
爱元元的哥哥
Unregistered / Unconfirmed
GUEST, unregistred user!
使用EmBedbedWb组件，它包含了直接从内寸加载的方法。
直接访问WebBrowser控件中的HTML源码
华中师范大学
卢小海
---- 为了实现在自己的程序中显示HTML文档，我们一般采用IE(Internet Explorer本文中简称为IE)发行时
附带的一个ActiveX控件TWebBrowser。这个控件使用和IE相同的内核，功能强大，并从Delphi5开始，正式得到
Inprise公司的支持，取代了原来的那个THTML控件，成为Delphi中显示HTML文档的首选控件。
---- 但是在实际编程过程中，我发现这个控件提供的功能有很多限制，比如对HTML文档的浏览，只能通过指定
URL或文件名来实现，不能像以往使用THTML控件那样直接读写HTML源码。因此如果程序动态生成了一段HTML文本，
就必须把文本内容先写到一个临时文件，然后再将此文件的文件名传递给WebBrowser控件，实现显示。
走这一个弯路使程序响应速度受到很大影响，而且容易遗留下一些"垃圾"(临时文件)。
---- 在考察了一些使用了WebBrowser控件的程序后，我发现大部分程序，如著名国产软件FoxMail，都是使用的
通过临时文件传递HTML文档的方法；但一些国外的软件，如MS自己的OutLook Express则不存在这个问题，而因为
其无需产生临时文件，因此对HTML文档的显示速度明显超过Foxmail。
---- 为此，我查阅了一些相关资料，最后在网友的帮助下找到了实现直接访问WebBrowser控件中的HTML源码的方法。
在此要特别感谢白云黄鹤BBS上的网友AngleFalls提供线索。
---- 其实，WebBrowser控件中的Document对象，这个对象提供了一个IPersistStreamInit接口，通过此接口，
我们可以方便地实现对HTML源码的读写。
---- 以下是IPersistStreamInit接口的相关定义及说明：
{ IPersistStream interface }
{$EXTERNALSYM IPersistStream}
IPersistStream = interface(IPersist)
['{00000109-0000-0000-C000-000000000046}']
function IsDirty: HResult; stdcall;
// 最后一次存盘后是否被修改
function Load(const stm: IStream): HResult; stdcall;
// 从流中载入
function Save(const stm: IStream;
fClearDirty: BOOL): HResult; stdcall;
// 保存到流
function GetSizeMax(out cbSize: Largeint):
HResult; stdcall; // 取得保存所需空间大小
end;
{ IPersistStreamInit interface }
{$EXTERNALSYM IPersistStreamInit}
IPersistStreamInit = interface(IPersistStream)
['{7FD52380-4E07-101B-AE2D-08002B2EC713}']
function InitNew: HResult; stdcall; // 初始化
end;
首先来实现写，因为这是最迫切的要求：
procedure SetHtml(const WebBrowser:
TWebBrowser; const Html: string);
var
Stream: IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then Exit;
hHTMLText := GlobalAlloc(GPTR, Length(Html) + 1);
if 0 = hHTMLText then RaiseLastWin32Error;
CopyMemory(Pointer(hHTMLText),
PChar(Html), Length(Html));
OleCheck(CreateStreamOnHGlobal
(hHTMLText, True, Stream));
try
OleCheck(WebBrowser.Document.
QueryInterface(IPersistStreamInit, psi));
try
OleCheck(psi.InitNew);
OleCheck(psi.Load(Stream));
finally
psi := nil;
end;
finally
Stream := nil;
end;
end;
---- 首先，此过程需要的两个参数，WebBrowser是显示目的控件，Html是需要显示的HTML源码；然后，先检查
WebBrowser.Document对象是否有效，无效则退出；接着在系统全局堆里分配一块内存，将需要显示的HTML源码
复制进去。这是因为下一步需要建立一个WebBrowser控件可以读取的流。GlobalAlloc函数的参数GPTR表示
需要分配一块固定的以0初始化过的内存区域，如果分配失败则返回0，则通过RaiseLastWin32Error函数引发
一个异常，提示用户；然后用CreateStreamOnHGlobal函数建立一个基于全局堆内存块的流，第二个参数如果
为True则流在释放时自动释放所占全局堆内存。如果建立成功则此流和刚刚建立的内存块共用同一块内存区域。
接着用WebBrowser.Document.QueryInterface函数建立一个IPersistStreamInit接口。然后
就可以直接使用此接口，psi.InitNew初始化状态；psi.Load(Stream)从流中载入HTML源码。
---- 至此，以Html参数指定的HTML源码就在WebBrowser参数指定的控件中显示出来。
---- 值得注意的是，每个关于COM接口的函数调用，也就是那些返回类型为HResult的函数，都必须以OleCheck包装，
因为一个不检查返回状态的COM接口操作实在太危险了；此外接口的释放，虽然Delphi可以在后台自动完成，但作为
一个好的编程习惯，还是应该显式地手工释放，释放只需将接口设为nil即可。
---- 接着来实现HTML源码的读：
function GetHtml(const WebBrowser:
TWebBrowser): string;
const
BufSize = $10000;
var
Size: Int64;
Stream: IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then Exit;
OleCheck(WebBrowser.Document.QueryInterface
(IPersistStreamInit, psi));
try
//OleCheck(psi.GetSizeMax(Size));
hHTMLText := GlobalAlloc(GPTR, BufSize);
if 0 = hHTMLText then RaiseLastWin32Error;
OleCheck(CreateStreamOnHGlobal(hHTMLText,
True, Stream));
try
OleCheck(psi.Save(Stream, False));
Size := StrLen(PChar(hHTMLText));
SetLength(Result, Size);
CopyMemory(PChar(Result), Pointer(hHTMLText),
Size);
finally
Stream := nil;
end;
finally
psi := nil;
end;
end;
---- 此函数有一个参数WebBrowser指定从那个控件读取HTML源码，返回一个字符串为此控件中的HTML源码。
首先还是要先检查WebBrowser.Document对象是否有效，无效则退出；然后取得IPersistStreamInit接口；
接着取得HTML源码的大小：本来应该使用IPersistStreamInit接口的GetSizeMax函数，但在我的机器
上测试，这个函数范围值衡为0，无效。因此只能先定义一个足够大的缓冲区，如BufSize = $10000字节(注意此
缓冲区应该足够大)；然后同样地分配全局堆内存块，建立流，然后将HTML文本写到流中。因为此HTML文本在流中
是以#0结尾的字符串，因此可以用Size := StrLen(PChar(hHTMLText))取得实际长度，用SetLength(Result, Size);
设置返回字符串长度为HTML源码实际长度，最后复制字符串到返回字符串中。
---- 至此，直接访问WebBrowser
控件中的HTML源码所需的两个函数全部解析完毕。
---- 不过需要注意的时，在使用这两个函数前，最好对WebBrowser.Document对象进行初始化。下面提供一个
函数，通过显示一个空白页面实现WebBrowser.Document对象初始化。
procedure ShowBlankPage(WebBrowser:
TWebBrowser);
var
URL: OleVariant;
begin
URL := 'about:blank';
WebBrowser.Navigate2(URL);
end;
---- 建议在你有WebBrowser控件的Form的FormCreate事件里调用此函数，初始化WebBrowser.Document对象。
---- 本文程序在Win NT + Delphi 5 环境下调试通过
直接访问WebBrowser控件中的HTML源码
华中师范大学
卢小海
---- 为了实现在自己的程序中显示HTML文档，我们一般采用IE(Internet Explorer本文中简称为IE)发行时
附带的一个ActiveX控件TWebBrowser。这个控件使用和IE相同的内核，功能强大，并从Delphi5开始，正式得到
Inprise公司的支持，取代了原来的那个THTML控件，成为Delphi中显示HTML文档的首选控件。
---- 但是在实际编程过程中，我发现这个控件提供的功能有很多限制，比如对HTML文档的浏览，只能通过指定
URL或文件名来实现，不能像以往使用THTML控件那样直接读写HTML源码。因此如果程序动态生成了一段HTML文本，
就必须把文本内容先写到一个临时文件，然后再将此文件的文件名传递给WebBrowser控件，实现显示。
走这一个弯路使程序响应速度受到很大影响，而且容易遗留下一些"垃圾"(临时文件)。
---- 在考察了一些使用了WebBrowser控件的程序后，我发现大部分程序，如著名国产软件FoxMail，都是使用的
通过临时文件传递HTML文档的方法；但一些国外的软件，如MS自己的OutLook Express则不存在这个问题，而因为
其无需产生临时文件，因此对HTML文档的显示速度明显超过Foxmail。
---- 为此，我查阅了一些相关资料，最后在网友的帮助下找到了实现直接访问WebBrowser控件中的HTML源码的方法。
在此要特别感谢白云黄鹤BBS上的网友AngleFalls提供线索。
---- 其实，WebBrowser控件中的Document对象，这个对象提供了一个IPersistStreamInit接口，通过此接口，
我们可以方便地实现对HTML源码的读写。
---- 以下是IPersistStreamInit接口的相关定义及说明：
{ IPersistStream interface }
{$EXTERNALSYM IPersistStream}
IPersistStream = interface(IPersist)
['{00000109-0000-0000-C000-000000000046}']
function IsDirty: HResult; stdcall;
// 最后一次存盘后是否被修改
function Load(const stm: IStream): HResult; stdcall;
// 从流中载入
function Save(const stm: IStream;
fClearDirty: BOOL): HResult; stdcall;
// 保存到流
function GetSizeMax(out cbSize: Largeint):
HResult; stdcall; // 取得保存所需空间大小
end;
{ IPersistStreamInit interface }
{$EXTERNALSYM IPersistStreamInit}
IPersistStreamInit = interface(IPersistStream)
['{7FD52380-4E07-101B-AE2D-08002B2EC713}']
function InitNew: HResult; stdcall; // 初始化
end;
首先来实现写，因为这是最迫切的要求：
procedure SetHtml(const WebBrowser:
TWebBrowser; const Html: string);
var
Stream: IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then Exit;
hHTMLText := GlobalAlloc(GPTR, Length(Html) + 1);
if 0 = hHTMLText then RaiseLastWin32Error;
CopyMemory(Pointer(hHTMLText),
PChar(Html), Length(Html));
OleCheck(CreateStreamOnHGlobal
(hHTMLText, True, Stream));
try
OleCheck(WebBrowser.Document.
QueryInterface(IPersistStreamInit, psi));
try
OleCheck(psi.InitNew);
OleCheck(psi.Load(Stream));
finally
psi := nil;
end;
finally
Stream := nil;
end;
end;
---- 首先，此过程需要的两个参数，WebBrowser是显示目的控件，Html是需要显示的HTML源码；然后，先检查
WebBrowser.Document对象是否有效，无效则退出；接着在系统全局堆里分配一块内存，将需要显示的HTML源码
复制进去。这是因为下一步需要建立一个WebBrowser控件可以读取的流。GlobalAlloc函数的参数GPTR表示
需要分配一块固定的以0初始化过的内存区域，如果分配失败则返回0，则通过RaiseLastWin32Error函数引发
一个异常，提示用户；然后用CreateStreamOnHGlobal函数建立一个基于全局堆内存块的流，第二个参数如果
为True则流在释放时自动释放所占全局堆内存。如果建立成功则此流和刚刚建立的内存块共用同一块内存区域。
接着用WebBrowser.Document.QueryInterface函数建立一个IPersistStreamInit接口。然后
就可以直接使用此接口，psi.InitNew初始化状态；psi.Load(Stream)从流中载入HTML源码。
---- 至此，以Html参数指定的HTML源码就在WebBrowser参数指定的控件中显示出来。
---- 值得注意的是，每个关于COM接口的函数调用，也就是那些返回类型为HResult的函数，都必须以OleCheck包装，
因为一个不检查返回状态的COM接口操作实在太危险了；此外接口的释放，虽然Delphi可以在后台自动完成，但作为
一个好的编程习惯，还是应该显式地手工释放，释放只需将接口设为nil即可。
---- 接着来实现HTML源码的读：
function GetHtml(const WebBrowser:
TWebBrowser): string;
const
BufSize = $10000;
var
Size: Int64;
Stream: IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then Exit;
OleCheck(WebBrowser.Document.QueryInterface
(IPersistStreamInit, psi));
try
//OleCheck(psi.GetSizeMax(Size));
hHTMLText := GlobalAlloc(GPTR, BufSize);
if 0 = hHTMLText then RaiseLastWin32Error;
OleCheck(CreateStreamOnHGlobal(hHTMLText,
True, Stream));
try
OleCheck(psi.Save(Stream, False));
Size := StrLen(PChar(hHTMLText));
SetLength(Result, Size);
CopyMemory(PChar(Result), Pointer(hHTMLText),
Size);
finally
Stream := nil;
end;
finally
psi := nil;
end;
end;
---- 此函数有一个参数WebBrowser指定从那个控件读取HTML源码，返回一个字符串为此控件中的HTML源码。
首先还是要先检查WebBrowser.Document对象是否有效，无效则退出；然后取得IPersistStreamInit接口；
接着取得HTML源码的大小：本来应该使用IPersistStreamInit接口的GetSizeMax函数，但在我的机器
上测试，这个函数范围值衡为0，无效。因此只能先定义一个足够大的缓冲区，如BufSize = $10000字节(注意此
缓冲区应该足够大)；然后同样地分配全局堆内存块，建立流，然后将HTML文本写到流中。因为此HTML文本在流中
是以#0结尾的字符串，因此可以用Size := StrLen(PChar(hHTMLText))取得实际长度，用SetLength(Result, Size);
设置返回字符串长度为HTML源码实际长度，最后复制字符串到返回字符串中。
---- 至此，直接访问WebBrowser
控件中的HTML源码所需的两个函数全部解析完毕。
---- 不过需要注意的时，在使用这两个函数前，最好对WebBrowser.Document对象进行初始化。下面提供一个
函数，通过显示一个空白页面实现WebBrowser.Document对象初始化。
procedure ShowBlankPage(WebBrowser:
TWebBrowser);
var
URL: OleVariant;
begin
URL := 'about:blank';
WebBrowser.Navigate2(URL);
end;
---- 建议在你有WebBrowser控件的Form的FormCreate事件里调用此函数，初始化WebBrowser.Document对象。
---- 本文程序在Win NT + Delphi 5 环境下调试通过
N
^nEWnEW^
Unregistered / Unconfirmed
GUEST, unregistred user!
这样：
WebBrowser1.Navigate('about:<html><p>.......</p></html>');
把分都给我吧！
WebBrowser1.Navigate('about:<html><p>.......</p></html>');
把分都给我吧！
B
BeginDelphi
Unregistered / Unconfirmed
GUEST, unregistred user!
哈哈！这样呀！
var Doc:OleVariant;
begin
WebBrowser1.Navigate("About:Blank");
while WebBrowser1.Busy do Application.ProcessMessage;
Doc := WebBrowser1.Document;
Doc.Write("<HTML><Body>test</Body><HTML>");
end;
var Doc:OleVariant;
begin
WebBrowser1.Navigate("About:Blank");
while WebBrowser1.Busy do Application.ProcessMessage;
Doc := WebBrowser1.Document;
Doc.Write("<HTML><Body>test</Body><HTML>");
end;
N
^nEWnEW^
Unregistered / Unconfirmed
GUEST, unregistred user!
我还有1分，能把分都给我吗？谢谢了。
P
pcspace
Unregistered / Unconfirmed
GUEST, unregistred user!
用About协议的朋友！我很抱歉的告诉你们：这种方法我早就知道了！但是有一个致命的弱点
一旦HTML里面插入Javascript！结果自己试验一下就直到了！此种答案枪毙！
爱元元的哥哥：
你贴的那一片文章我早就找到过！但是似乎有问题！如果可能你是否可以写一个例程！
EmBedbedWb 那里有（D6）？？？
如果帮我解决这个问题（必须能够兼容 JS、VBS脚本代码）除了这200分另外再给100分！
绝不食言！！！
一旦HTML里面插入Javascript！结果自己试验一下就直到了！此种答案枪毙！
爱元元的哥哥：
你贴的那一片文章我早就找到过！但是似乎有问题！如果可能你是否可以写一个例程！
EmBedbedWb 那里有（D6）？？？
如果帮我解决这个问题（必须能够兼容 JS、VBS脚本代码）除了这200分另外再给100分！
绝不食言！！！
A
Adnil
Unregistered / Unconfirmed
GUEST, unregistred user!
我来给你一个吧！
function LoadFromStream(const AStream: TStream): HRESULT;
begin
AStream.seek(0, 0);
Result := (Webbrowser1.Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream));
end;
procedure LoadFromStrings(const AStrings: TStrings);
var
M: TMemoryStream;
begin
M := TMemoryStream.Create;
try
AStrings.SaveToStream(M);
Result := LoadFromStream(M);
finally
M.free;
end;
end;
function LoadFromStream(const AStream: TStream): HRESULT;
begin
AStream.seek(0, 0);
Result := (Webbrowser1.Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream));
end;
procedure LoadFromStrings(const AStrings: TStrings);
var
M: TMemoryStream;
begin
M := TMemoryStream.Create;
try
AStrings.SaveToStream(M);
Result := LoadFromStream(M);
finally
M.free;
end;
end;
R
Rzhou
Unregistered / Unconfirmed
GUEST, unregistred user!
我没安装DELPHI，明天再安装，
我这有VB的程序，你改一下吧，
希望能对你有所帮助。。。
brwWebBrowser.Navigate "about:blank"
brwWebBrowser.Document.writeln "<HTML>"
brwWebBrowser.Document.writeln "<HEAD>"
brwWebBrowser.Document.writeln "<TITLE>"
brwWebBrowser.Document.writeln "</TITLE>"
brwWebBrowser.Document.writeln "<meta name=GENERATOR content=Microsoft Visual Studio.NET 7.0>"
brwWebBrowser.Document.writeln "</HEAD>"
brwWebBrowser.Document.writeln "<BODY bottomMargin=0 leftMargin=0 topMargin=0 rightMargin=0 scroll=no>"
brwWebBrowser.Document.writeln "<iframe src=http://www.google.com width=100% height=50% border=0 frameborder=0 scrolling=no noresize marginwidth=0 marginheight =0></iframe>"
brwWebBrowser.Document.writeln "<br><br>hello"
brwWebBrowser.Document.writeln "</BODY>"
brwWebBrowser.Document.writeln "</HTML>"
brwWebBrowser.Refresh2
我这有VB的程序，你改一下吧，
希望能对你有所帮助。。。
brwWebBrowser.Navigate "about:blank"
brwWebBrowser.Document.writeln "<HTML>"
brwWebBrowser.Document.writeln "<HEAD>"
brwWebBrowser.Document.writeln "<TITLE>"
brwWebBrowser.Document.writeln "</TITLE>"
brwWebBrowser.Document.writeln "<meta name=GENERATOR content=Microsoft Visual Studio.NET 7.0>"
brwWebBrowser.Document.writeln "</HEAD>"
brwWebBrowser.Document.writeln "<BODY bottomMargin=0 leftMargin=0 topMargin=0 rightMargin=0 scroll=no>"
brwWebBrowser.Document.writeln "<iframe src=http://www.google.com width=100% height=50% border=0 frameborder=0 scrolling=no noresize marginwidth=0 marginheight =0></iframe>"
brwWebBrowser.Document.writeln "<br><br>hello"
brwWebBrowser.Document.writeln "</BODY>"
brwWebBrowser.Document.writeln "</HTML>"
brwWebBrowser.Refresh2
L
LiChaoHui
Unregistered / Unconfirmed
GUEST, unregistred user!
使用APP吧，
http://www.playicq.com/dispdoc.php?t=&id=2543
需要先安装VCLZip2.23
http://www.playicq.com/dispdoc.php?t=&id=2543
需要先安装VCLZip2.23
N
^nEWnEW^
Unregistered / Unconfirmed
GUEST, unregistred user!
to pcspace:
使用about:............的方法绝对没错。script照样可以使用。不信请看：
WebBrowser1.Navigate('about:<script>document.write("ddd");</script>');
如果还不信，那就把你的script发过来看看，可能是你写错了。真的。
使用about:............的方法绝对没错。script照样可以使用。不信请看：
WebBrowser1.Navigate('about:<script>document.write("ddd");</script>');
如果还不信，那就把你的script发过来看看，可能是你写错了。真的。
P
pcspace
Unregistered / Unconfirmed
GUEST, unregistred user!
^nEWnEW^
我试验了用about协议，但是还不行
procedure TForm1.Button1Click(Sender: TObject);
var
s:string;
begin
s:='about:'+Memo1.Text ;
WebBrowser1.Navigate(s);
end;
Memo1的Lines的代码为
pcspace.myetang.com/JSTest.htm的代码！
不行的！
Rzhou:
document在Delphi里面有writeln方法吗？？？（没发现）。
Adnil：
你的方法似乎也不行 IPersistStreamInit未定义？？？
我试验了用about协议，但是还不行
procedure TForm1.Button1Click(Sender: TObject);
var
s:string;
begin
s:='about:'+Memo1.Text ;
WebBrowser1.Navigate(s);
end;
Memo1的Lines的代码为
pcspace.myetang.com/JSTest.htm的代码！
不行的！
Rzhou:
document在Delphi里面有writeln方法吗？？？（没发现）。
Adnil：
你的方法似乎也不行 IPersistStreamInit未定义？？？
S
shadow123
Unregistered / Unconfirmed
GUEST, unregistred user!
转载:
---- 为了实现在自己的程序中显示HTML文档，我们一般采用IE(Internet Explorer本文中简称为IE)发行时
附带的一个ActiveX控件TWebBrowser。这个控件使用和IE相同的内核，功能强大，并从Delphi5开始，正式得到
Inprise公司的支持，取代了原来的那个THTML控件，成为Delphi中显示HTML文档的首选控件。
---- 但是在实际编程过程中，我发现这个控件提供的功能有很多限制，比如对HTML文档的浏览，只能通过指定
URL或文件名来实现，不能像以往使用THTML控件那样直接读写HTML源码。因此如果程序动态生成了一段HTML文本，
就必须把文本内容先写到一个临时文件，然后再将此文件的文件名传递给WebBrowser控件，实现显示。
走这一个弯路使程序响应速度受到很大影响，而且容易遗留下一些"垃圾"(临时文件)。
---- 在考察了一些使用了WebBrowser控件的程序后，我发现大部分程序，如著名国产软件FoxMail，都是使用的
通过临时文件传递HTML文档的方法；但一些国外的软件，如MS自己的OutLook Express则不存在这个问题，而因为
其无需产生临时文件，因此对HTML文档的显示速度明显超过Foxmail。
---- 为此，我查阅了一些相关资料，最后在网友的帮助下找到了实现直接访问WebBrowser控件中的HTML源码的方法。
在此要特别感谢白云黄鹤BBS上的网友AngleFalls提供线索。
---- 其实，WebBrowser控件中的Document对象，这个对象提供了一个IPersistStreamInit接口，通过此接口，
我们可以方便地实现对HTML源码的读写。
---- 以下是IPersistStreamInit接口的相关定义及说明：
{ IPersistStream interface }
{$EXTERNALSYM IPersistStream}
IPersistStream = interface(IPersist)
['{00000109-0000-0000-C000-000000000046}']
function IsDirty: HResult; stdcall;
// 最后一次存盘后是否被修改
function Load(const stm: IStream): HResult; stdcall;
// 从流中载入
function Save(const stm: IStream;
fClearDirty: BOOL): HResult; stdcall;
// 保存到流
function GetSizeMax(out cbSize: Largeint):
HResult; stdcall; // 取得保存所需空间大小
end;
{ IPersistStreamInit interface }
{$EXTERNALSYM IPersistStreamInit}
IPersistStreamInit = interface(IPersistStream)
['{7FD52380-4E07-101B-AE2D-08002B2EC713}']
function InitNew: HResult; stdcall; // 初始化
end;
首先来实现写，因为这是最迫切的要求：
procedure SetHtml(const WebBrowser:
TWebBrowser; const Html: string);
var
Stream: IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then Exit;
hHTMLText := GlobalAlloc(GPTR, Length(Html) + 1);
if 0 = hHTMLText then RaiseLastWin32Error;
CopyMemory(Pointer(hHTMLText),
PChar(Html), Length(Html));
OleCheck(CreateStreamOnHGlobal
(hHTMLText, True, Stream));
try
OleCheck(WebBrowser.Document.
QueryInterface(IPersistStreamInit, psi));
try
OleCheck(psi.InitNew);
OleCheck(psi.Load(Stream));
finally
psi := nil;
end;
finally
Stream := nil;
end;
end;
---- 首先，此过程需要的两个参数，WebBrowser是显示目的控件，Html是需要显示的HTML源码；然后，先检查
WebBrowser.Document对象是否有效，无效则退出；接着在系统全局堆里分配一块内存，将需要显示的HTML源码
复制进去。这是因为下一步需要建立一个WebBrowser控件可以读取的流。GlobalAlloc函数的参数GPTR表示
需要分配一块固定的以0初始化过的内存区域，如果分配失败则返回0，则通过RaiseLastWin32Error函数引发
一个异常，提示用户；然后用CreateStreamOnHGlobal函数建立一个基于全局堆内存块的流，第二个参数如果
为True则流在释放时自动释放所占全局堆内存。如果建立成功则此流和刚刚建立的内存块共用同一块内存区域。
接着用WebBrowser.Document.QueryInterface函数建立一个IPersistStreamInit接口。然后
就可以直接使用此接口，psi.InitNew初始化状态；psi.Load(Stream)从流中载入HTML源码。
---- 至此，以Html参数指定的HTML源码就在WebBrowser参数指定的控件中显示出来。
---- 值得注意的是，每个关于COM接口的函数调用，也就是那些返回类型为HResult的函数，都必须以OleCheck包装，
因为一个不检查返回状态的COM接口操作实在太危险了；此外接口的释放，虽然Delphi可以在后台自动完成，但作为
一个好的编程习惯，还是应该显式地手工释放，释放只需将接口设为nil即可。
---- 接着来实现HTML源码的读：
function GetHtml(const WebBrowser:
TWebBrowser): string;
const
BufSize = $10000;
var
Size: Int64;
Stream: IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then Exit;
OleCheck(WebBrowser.Document.QueryInterface
(IPersistStreamInit, psi));
try
//OleCheck(psi.GetSizeMax(Size));
hHTMLText := GlobalAlloc(GPTR, BufSize);
if 0 = hHTMLText then RaiseLastWin32Error;
OleCheck(CreateStreamOnHGlobal(hHTMLText,
True, Stream));
try
OleCheck(psi.Save(Stream, False));
Size := StrLen(PChar(hHTMLText));
SetLength(Result, Size);
CopyMemory(PChar(Result), Pointer(hHTMLText),
Size);
finally
Stream := nil;
end;
finally
psi := nil;
end;
end;
---- 此函数有一个参数WebBrowser指定从那个控件读取HTML源码，返回一个字符串为此控件中的HTML源码。
首先还是要先检查WebBrowser.Document对象是否有效，无效则退出；然后取得IPersistStreamInit接口；
接着取得HTML源码的大小：本来应该使用IPersistStreamInit接口的GetSizeMax函数，但在我的机器
上测试，这个函数范围值衡为0，无效。因此只能先定义一个足够大的缓冲区，如BufSize = $10000字节(注意此
缓冲区应该足够大)；然后同样地分配全局堆内存块，建立流，然后将HTML文本写到流中。因为此HTML文本在流中
是以#0结尾的字符串，因此可以用Size := StrLen(PChar(hHTMLText))取得实际长度，用SetLength(Result, Size);
设置返回字符串长度为HTML源码实际长度，最后复制字符串到返回字符串中。
---- 至此，直接访问WebBrowser
控件中的HTML源码所需的两个函数全部解析完毕。
---- 不过需要注意的时，在使用这两个函数前，最好对WebBrowser.Document对象进行初始化。下面提供一个
函数，通过显示一个空白页面实现WebBrowser.Document对象初始化。
procedure ShowBlankPage(WebBrowser:
TWebBrowser);
var
URL: OleVariant;
begin
URL := 'about:blank';
WebBrowser.Navigate2(URL);
end;
---- 建议在你有WebBrowser控件的Form的FormCreate事件里调用此函数，初始化WebBrowser.Document对象。
---- 为了实现在自己的程序中显示HTML文档，我们一般采用IE(Internet Explorer本文中简称为IE)发行时
附带的一个ActiveX控件TWebBrowser。这个控件使用和IE相同的内核，功能强大，并从Delphi5开始，正式得到
Inprise公司的支持，取代了原来的那个THTML控件，成为Delphi中显示HTML文档的首选控件。
---- 但是在实际编程过程中，我发现这个控件提供的功能有很多限制，比如对HTML文档的浏览，只能通过指定
URL或文件名来实现，不能像以往使用THTML控件那样直接读写HTML源码。因此如果程序动态生成了一段HTML文本，
就必须把文本内容先写到一个临时文件，然后再将此文件的文件名传递给WebBrowser控件，实现显示。
走这一个弯路使程序响应速度受到很大影响，而且容易遗留下一些"垃圾"(临时文件)。
---- 在考察了一些使用了WebBrowser控件的程序后，我发现大部分程序，如著名国产软件FoxMail，都是使用的
通过临时文件传递HTML文档的方法；但一些国外的软件，如MS自己的OutLook Express则不存在这个问题，而因为
其无需产生临时文件，因此对HTML文档的显示速度明显超过Foxmail。
---- 为此，我查阅了一些相关资料，最后在网友的帮助下找到了实现直接访问WebBrowser控件中的HTML源码的方法。
在此要特别感谢白云黄鹤BBS上的网友AngleFalls提供线索。
---- 其实，WebBrowser控件中的Document对象，这个对象提供了一个IPersistStreamInit接口，通过此接口，
我们可以方便地实现对HTML源码的读写。
---- 以下是IPersistStreamInit接口的相关定义及说明：
{ IPersistStream interface }
{$EXTERNALSYM IPersistStream}
IPersistStream = interface(IPersist)
['{00000109-0000-0000-C000-000000000046}']
function IsDirty: HResult; stdcall;
// 最后一次存盘后是否被修改
function Load(const stm: IStream): HResult; stdcall;
// 从流中载入
function Save(const stm: IStream;
fClearDirty: BOOL): HResult; stdcall;
// 保存到流
function GetSizeMax(out cbSize: Largeint):
HResult; stdcall; // 取得保存所需空间大小
end;
{ IPersistStreamInit interface }
{$EXTERNALSYM IPersistStreamInit}
IPersistStreamInit = interface(IPersistStream)
['{7FD52380-4E07-101B-AE2D-08002B2EC713}']
function InitNew: HResult; stdcall; // 初始化
end;
首先来实现写，因为这是最迫切的要求：
procedure SetHtml(const WebBrowser:
TWebBrowser; const Html: string);
var
Stream: IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then Exit;
hHTMLText := GlobalAlloc(GPTR, Length(Html) + 1);
if 0 = hHTMLText then RaiseLastWin32Error;
CopyMemory(Pointer(hHTMLText),
PChar(Html), Length(Html));
OleCheck(CreateStreamOnHGlobal
(hHTMLText, True, Stream));
try
OleCheck(WebBrowser.Document.
QueryInterface(IPersistStreamInit, psi));
try
OleCheck(psi.InitNew);
OleCheck(psi.Load(Stream));
finally
psi := nil;
end;
finally
Stream := nil;
end;
end;
---- 首先，此过程需要的两个参数，WebBrowser是显示目的控件，Html是需要显示的HTML源码；然后，先检查
WebBrowser.Document对象是否有效，无效则退出；接着在系统全局堆里分配一块内存，将需要显示的HTML源码
复制进去。这是因为下一步需要建立一个WebBrowser控件可以读取的流。GlobalAlloc函数的参数GPTR表示
需要分配一块固定的以0初始化过的内存区域，如果分配失败则返回0，则通过RaiseLastWin32Error函数引发
一个异常，提示用户；然后用CreateStreamOnHGlobal函数建立一个基于全局堆内存块的流，第二个参数如果
为True则流在释放时自动释放所占全局堆内存。如果建立成功则此流和刚刚建立的内存块共用同一块内存区域。
接着用WebBrowser.Document.QueryInterface函数建立一个IPersistStreamInit接口。然后
就可以直接使用此接口，psi.InitNew初始化状态；psi.Load(Stream)从流中载入HTML源码。
---- 至此，以Html参数指定的HTML源码就在WebBrowser参数指定的控件中显示出来。
---- 值得注意的是，每个关于COM接口的函数调用，也就是那些返回类型为HResult的函数，都必须以OleCheck包装，
因为一个不检查返回状态的COM接口操作实在太危险了；此外接口的释放，虽然Delphi可以在后台自动完成，但作为
一个好的编程习惯，还是应该显式地手工释放，释放只需将接口设为nil即可。
---- 接着来实现HTML源码的读：
function GetHtml(const WebBrowser:
TWebBrowser): string;
const
BufSize = $10000;
var
Size: Int64;
Stream: IStream;
hHTMLText: HGLOBAL;
psi: IPersistStreamInit;
begin
if not Assigned(WebBrowser.Document) then Exit;
OleCheck(WebBrowser.Document.QueryInterface
(IPersistStreamInit, psi));
try
//OleCheck(psi.GetSizeMax(Size));
hHTMLText := GlobalAlloc(GPTR, BufSize);
if 0 = hHTMLText then RaiseLastWin32Error;
OleCheck(CreateStreamOnHGlobal(hHTMLText,
True, Stream));
try
OleCheck(psi.Save(Stream, False));
Size := StrLen(PChar(hHTMLText));
SetLength(Result, Size);
CopyMemory(PChar(Result), Pointer(hHTMLText),
Size);
finally
Stream := nil;
end;
finally
psi := nil;
end;
end;
---- 此函数有一个参数WebBrowser指定从那个控件读取HTML源码，返回一个字符串为此控件中的HTML源码。
首先还是要先检查WebBrowser.Document对象是否有效，无效则退出；然后取得IPersistStreamInit接口；
接着取得HTML源码的大小：本来应该使用IPersistStreamInit接口的GetSizeMax函数，但在我的机器
上测试，这个函数范围值衡为0，无效。因此只能先定义一个足够大的缓冲区，如BufSize = $10000字节(注意此
缓冲区应该足够大)；然后同样地分配全局堆内存块，建立流，然后将HTML文本写到流中。因为此HTML文本在流中
是以#0结尾的字符串，因此可以用Size := StrLen(PChar(hHTMLText))取得实际长度，用SetLength(Result, Size);
设置返回字符串长度为HTML源码实际长度，最后复制字符串到返回字符串中。
---- 至此，直接访问WebBrowser
控件中的HTML源码所需的两个函数全部解析完毕。
---- 不过需要注意的时，在使用这两个函数前，最好对WebBrowser.Document对象进行初始化。下面提供一个
函数，通过显示一个空白页面实现WebBrowser.Document对象初始化。
procedure ShowBlankPage(WebBrowser:
TWebBrowser);
var
URL: OleVariant;
begin
URL := 'about:blank';
WebBrowser.Navigate2(URL);
end;
---- 建议在你有WebBrowser控件的Form的FormCreate事件里调用此函数，初始化WebBrowser.Document对象。
Z
zw84611
Unregistered / Unconfirmed
GUEST, unregistred user!
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
OleCtrls, SHDocVw, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
WebBrowser1: TWebBrowser;
procedure Button1Click(Sender: TObject);
procedure WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses MSHTML, Activex;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
vv: Variant;
HTMLDocument: IHTMLDocument2;
Content: string;
begin
tag := 0;
WebBrowser1.Navigate('about:blank');
while(tag=0) do Application.ProcessMessages;
vv := VarArrayCreate([0, 0], varVariant);
Content := '<html><body><p>hello world!</p></body></html>';
vv[0] := Content;
HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
HTMLDocument.Write(PSafeArray(TVarData(vv).VArray));
HTMLDocument.Close;
end;
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin
tag := 1;
end;
end.
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
OleCtrls, SHDocVw, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
WebBrowser1: TWebBrowser;
procedure Button1Click(Sender: TObject);
procedure WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses MSHTML, Activex;
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
var
vv: Variant;
HTMLDocument: IHTMLDocument2;
Content: string;
begin
tag := 0;
WebBrowser1.Navigate('about:blank');
while(tag=0) do Application.ProcessMessages;
vv := VarArrayCreate([0, 0], varVariant);
Content := '<html><body><p>hello world!</p></body></html>';
vv[0] := Content;
HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
HTMLDocument.Write(PSafeArray(TVarData(vv).VArray));
HTMLDocument.Close;
end;
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
begin
tag := 1;
end;
end.
爱
爱元元的哥哥
Unregistered / Unconfirmed
GUEST, unregistred user!
{$DEFINE USE_IOLECOMMANDTARGET}
//***********************************************************
// EmbeddedWb ver 1.16b (Oct. 15 , 2001) *
// *
// For Delphi 4, 5 and 6 *
// Freeware Component *
// by *
// Per Linds?Larsen *
// per.lindsoe@larsen.mail.dk *
// *
// *
// Contributors: *
// *
// Mathias Walter (walter@coint.de) *
// - all messagehandling code *
// *
// Neil Moss (NeilM@BuchananInternational.com) *
// - code for setting downloadoptions *
// *
// Documentation and updated versions: *
// *
// http://www.euromind.com/iedelphi *
//***********************************************************
unit EmbeddedWB;
interface
uses
{$IFDEF VER140}Variants, {$ENDIF}
IEConst, IEUtils, Registry, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
EXTCtrls, OleCtrls, Mshtml, SHDocVw, ActiveX, shlObj, Wininet, Urlmon, shellapi;
type
{$IFDEF USE_IOLECOMMANDTARGET}
TScriptErrorEvent = procedure(Sender: TObject; ErrorLine, ErrorCharacter, ErrorCode, ErrorMessage, ErrorUrl: string;
var ContinueScript: Boolean; var Showdialog: Boolean) of object;
TRefreshEvent = procedure(Sender: TObject; CmdID: Integer; var Cancel: Boolean) of object;
TUnloadEvent = procedure(Sender: TObject) of object;
{$ENDIF}
TGetOverrideKeyPathEvent = function(pchKey: POLESTR; dw: DWORD): HRESULT of object;
TShowContextMenuEvent = function(const dwID: DWORD; const ppt: PPOINT;
const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT of object;
TGetHostInfoEvent = function(var pInfo: TDOCHOSTUIINFO): HRESULT of object;
TShowUIEvent = function(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HRESULT of object;
THideUIEvent = function: HRESULT of object;
TUpdateUIEvent = function: HRESULT of object;
TEnableModelessEvent = function(const fEnable: BOOL): HRESULT of object;
TOnDocWindowActivateEvent = function(const fActivate: BOOL): HRESULT of object;
TOnFrameWindowActivateEvent = function(const fActivate: BOOL): HRESULT of object;
TResizeBorderEvent = function(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow;
const fRameWindow: BOOL): HRESULT of object;
TTranslateAcceleratorEvent = function(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
const nCmdID: DWORD): HRESULT of object;
TGetOptionKeyPathEvent = function(var pchKey: POLESTR; const dw: DWORD): HRESULT of object;
TGetDropTargetEvent = function(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HRESULT of object;
TGetExternalEvent = function(out ppDispatch: IDispatch): HRESULT of object;
TTranslateUrlEvent = function(const dwTranslate: DWORD; const pchURLIn: POLESTR;
var ppchURLOut: POLESTR): HRESULT of object;
TFilterDataObjectEvent = function(const pDO: IDataObject;
out ppDORet: IDataObject): HRESULT of object;
TShowMessageEvent = function(hwnd: THandle;
lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR;
dwHelpContext: longint; var plResult: LRESULT): HRESULT of object;
TShowHelpEvent = function(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer;
dwData: longint; ptMouse: TPoint;
var pDispatchObjectHit: IDispatch): HRESULT of object;
TGetTypeInFoCountEvent = function(out Count: Integer): HResult of object;
TGetTypeInfoEvent = function(Index, LocaleID: Integer; out TypeInfo: ITypeInfo): HResult of object;
TGetIDsOfNamesEvent = function(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult of object;
TInvokeEvent = function(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params: TagDispParams; VarResult, ExcepInfo, ArgErr: Pointer): HResult of object;
TQueryServiceEvent = function(const rsid, iid: TGuid; out Obj: IUnknown): HResult of object;
TShowDialogEvent = procedure(Sender: TObject; h: THandle) of object;
TDownloadControlOption = (DLCTL_DLIMAGES, DLCTL_VIDEOS, DLCTL_BGSOUNDS,
DLCTL_NO_SCRIPTS, DLCTL_NO_JAVA, DLCTL_NO_RUNACTIVEXCTLS, DLCTL_NO_DLACTIVEXCTLS,
DLCTL_DOWNLOADONLY, DLCTL_NO_FRAMEDOWNLOAD, DLCTL_RESYNCHRONIZE, DLCTL_PRAGMA_NO_CACHE,
DLCTL_NO_BEHAVIORS, DLCTL_NO_METACHARSET, DLCTL_URL_ENCODING_DISABLE_UTF8,
DLCTL_URL_ENCODING_ENABLE_UTF8, DLCTL_FORCEOFFLINE, DLCTL_NO_CLIENTPULL,
DLCTL_SILENT, DLCTL_OFFLINE);
TDownloadControlOptions = set of TDownloadControlOption;
TUserInterfaceOption = (DIALOG, DISABLE_HELP_MENU, NO3DBORDER,
SCROLL_NO, DISABLE_SCRIPT_INACTIVE, OPENNEWWIN, DISABLE_OFFSCREEN,
FLAT_SCROLLBAR, DIV_BLOCKDEFAULT, ACTIVATE_CLIENTHIT_ONLY, OVERRIDEBEHAVIORFACTORY,
CODEPAGELINKEDFONTS, URL_ENCODING_DISABLE_UTF8, URL_ENCODING_ENABLE_UTF8,
ENABLE_FORMS_AUTOCOMPLETE, ENABLE_INPLACE_NAVIGATION, IME_ENABLE_RECONVERSION);
TUserInterfaceOptions = set of TUserInterfaceOption;
type
TMeasure = (mMetric, mUS);
TPrintOrientationOption = (poPortrait, poLandscape);
TMargins = class(TPersistent)
private
FLeft: Real;
FRight: Real;
FTop: Real;
FBottom: real;
published
property Left: Real read FLeft write FLeft;
property Right: Real read FRight write FRight;
property Top: Real read FTop write FTop;
property Bottom: Real read FBottom write FBottom;
end;
TPrintOptions = class(TPersistent)
private
FHTMLHeader: TStrings;
FHeader: string;
FFooter: string;
FMargins: TMargins;
FOrientation: TPrintOrientationOption;
FMeasure: TMeasure;
procedure SetHTMLHeader(const Value: Tstrings);
property Measure: TMeasure read FMeasure;
published
property Margins: TMargins read FMargins write FMargins;
property Header: string read FHeader write FHeader;
property HTMLHeader: TStrings read FHTMLHeader write SetHTMLHeader;
property Footer: string read FFooter write FFooter;
property Orientation: TPrintOrientationOption read FOrientation write FOrientation;
end;
TEmbeddedWB = class(TWebbrowser, IDocHostShowUI, IDocHostUIHandler,
IDocHostUIHandler2, IDispatch, IServiceProvider
{$IFDEF USE_IOLECOMMANDTARGET}, IOleCommandTarget{$ENDIF})
private
{$IFDEF VER120}
SaveMessage: TMessageEvent;
{$ENDIF}
FUserAgent: string;
FReplaceCaption: Boolean;
FPrintOptions: TPrintOPtions;
FDownloadControlOptions: TDownloadControlOptions;
FUserInterfaceOptions: TUserInterfaceOptions;
{$IFDEF USE_IOLECOMMANDTARGET}
FOnUnload: TUnloadEvent;
FOnRefresh: TRefreshEvent;
FOnScriptError: TScriptErrorEvent;
{$ENDIF}
FOnGetOverrideKeyPath: TGetOverrideKeypathEvent;
FOnShowContextMenu: TShowcontextmenuEvent;
FOnGetHostInfo: TGetHostInfoEvent;
FOnShowUI: TShowUIEvent;
FOnHideUI: THideUIEvent;
FOnUpdateUI: TUpdateUIEvent;
FOnEnableModeless: TEnableModelessEvent;
FOnOnDocWindowActivate: TOnDocWindowActivateEvent;
FOnOnFrameWindowActivate: TOnFrameWindowActivateEvent;
FOnResizeBorder: TResizeBorderEvent;
FOnTranslateAccelerator: TTranslateAcceleratorEvent;
FOnGetOptionKeyPath: TGetOptionKeyPathEvent;
FOnGetDropTarget: TGetDropTargetEvent;
FOnGetExternal: TGetExternalEvent;
FOnTranslateUrL: TTranslateUrlEvent;
FOnFilterDataObject: TFilterDataObjectEvent;
FHelpFile: string;
FOnShowMessage: TShowMessageEvent;
FOnShowHelp: TShowHelpEvent;
FOnGetTypeInfoCount: TGetTypeInfoCountEvent;
FOnGetTypeInfo: TGetTypeInfoEvent;
FOnGetIDsOfNames: TGetIDsOfNamesEvent;
FOnInvoke: TInvokeEvent;
FOnQueryService: TQueryServiceEvent;
FOldWindowProc: TWndMethod;
FParentForm: TForm;
FDownloadOptionValue: Longint;
FUserInterfaceValue: Cardinal;
FOnCloseQuery: TCloseQueryEvent;
FOnShowDialog: TShowDialogEvent;
OldWBWndProc: TWndMethod;
RuntimeMeasure: TMeasure;
DDEHWnd: THandle;
FEnableDDE: Boolean;
FfpExceptions: Boolean;
procedure SetUserAgent;
procedure RemoveUserAgent;
procedure GetPrintValues;
procedure Hook;
procedure UnHook;
procedure FormWndProc(var AMsg: TMessage);
procedure DDEWndProc(var AMsg: TMessage);
procedure WBWndProc(var Message: TMessage);
procedure SetDownloadOptions(const Value: TDownloadControlOptions);
procedure SetUserInterfaceOptions(const Value: TUserInterfaceOptions);
procedure SetfpExceptions(const Value: Boolean);
procedure UpdateDownloadControlValue;
procedure UpdateUserInterfaceValue;
protected
function DDETerminate(iwParam: WPARAM; ilParam: LPARAM): BOOL;
function DDEInitiate(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
function DDEExecute(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
function GetOverrideKeyPath(pchKey: POLESTR; dw: DWORD): HRESULT; stdcall;
{$IFDEF USE_IOLECOMMANDTARGET}
function QueryStatus(CmdGroup: PGUID; cCmds: Cardinal;
prgCmds: POleCmd; CmdText: POleCmdText): HResult; stdcall;
function Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
const vaIn: OleVariant; var vaOut: OleVariant): HResult; stdcall;
{$ENDIF}
function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT; stdcall;
function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;
function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;
function HideUI: HRESULT; stdcall;
function UpdateUI: HRESULT; stdcall;
function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;
function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
function ResizeBorder(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow;
const FrameWindow: BOOL): HRESULT; stdcall;
function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
const nCmdID: DWORD): HRESULT; stdcall;
function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; stdcall;
function GetDropTarget(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HRESULT; stdcall;
function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;
function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR;
var ppchURLOut: POLESTR): HRESULT; stdcall;
function FilterDataObject(const pDO: IDataObject;
out ppDORet: IDataObject): HRESULT; stdcall;
function ShowMessage(hwnd: THandle;
lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR;
dwHelpContext: longint; var plResult: LRESULT): HRESULT; stdcall;
function ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer;
dwData: longint; ptMouse: TPoint;
var pDispatchObjectHit: IDispatch): HRESULT; stdcall;
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
{$IFDEF VER120}
procedure IEMessageHandler(var Msg: TMsg; var Handled: Boolean);
{$ENDIF}
function QueryService(const rsid, iid: TGuid; out Obj): HResult; stdcall;
function OpenClient(Client: string): Boolean;
function PrintMarginStr(M: Real): PChar;
public
SecurityManager: IInternetSecurityManager;
ZoneManager: IInternetZoneManager;
function ShowMailClient: Boolean;
function ShowNewsClient: Boolean;
function ShowAddressBook: Boolean;
function ShowCalendar: Boolean;
function ShowInternetCall: Boolean;
procedure AssignDocument;
procedure SetFocusToDoc;
procedure InvokeCMD(InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant);
procedure Go(Url: string);
procedure Print;
procedure OpenDialog;
procedure SaveDialog;
procedure PrintSetup;
procedure PageSetup(UsePrintOptions: Boolean);
procedure ViewSource;
procedure Properties;
procedure Options;
procedure Find;
{$IFDEF VER120}
procedure EnableMessagehandler;
procedure DisableMessagehandler;
{$ENDIF}
procedure Copy;
procedure SelectAll;
procedure Zoom(ZoomValue: Integer);
function ZoomRangeHigh: Integer;
function ZoomRangeLow: Integer;
function ZoomValue: Integer;
procedure NavigatePidl(pidl: PItemIdlist);
procedure NavigateFolder(CSIDL: Integer);
procedure SetGlobalOffline(Value: Boolean);
function IsGlobalOffline: boolean;
function LoadFrameFromStrings(Frameno: Integer; const AStrings: TStrings): HResult;
function LoadFrameFromStream(FrameNo: Integer; AStream: TStream): HRESULT;
function SaveFrameToFile(FrameNo: Integer; const Fname: string): HRESULT;
function SaveFrameToStream(FrameNo: Integer; AStream: TStream): HRESULT;
function SaveFrameToStrings(FrameNo: Integer; AStrings: TStrings): HRESULT;
function LoadFromStream(const AStream: TStream): HRESULT;
function LoadFromStrings(const AStrings: TStrings): HRESULT;
function SaveToStrings(AStrings: TStrings): HRESULT;
function SaveToStream(AStream: TStream): HRESULT;
function SaveToFile(const Fname: string): HRESULT;
constructor Create(Owner: TComponent); override;
procedure Loaded; override;
destructor Destroy; override;
procedure PrintPreView;
procedure PrintWithOptions;
function GetFrame(FrameNo: Integer): IWebbrowser2;
function FrameCount: LongInt;
procedure GetThumbnail(var Image: TImage);
procedure ClearHistory;
procedure ClearCache;
published
property DownloadOptions: TDownloadControlOptions read FDownloadControlOptions write SetDownloadOptions;
property UserInterfaceOptions: TUserInterfaceOptions read FUserInterfaceOptions write SetUserInterfaceOptions;
{$IFDEF USE_IOLECOMMANDTARGET}
property OnRefresh: TRefreshEvent read FOnRefresh write FOnRefresh;
property OnScriptError: TScriptErrorEvent read FOnScriptError write FOnScriptError;
property OnUnload: TUnloadEvent read FOnUnload write FOnUnload;
{$ENDIF}
property OnGetOverrideKeyPath: TGetOVerrideKeypathEvent read FOnGetOverrideKeyPath write FOnGetOverrideKeyPath;
property OnShowContextMenu: TShowContextMenuEvent read FOnShowContextmenu write FOnShowContextmenu;
property OnGetHostInfo: TGetHostInfoEvent read FOnGethostinfo write fongethostinfo;
property OnShowUI: TShowUIEvent read FOnShowUI write FOnShowUI;
property OnHideUI: THideUIEvent read FOnHideUI write FOnHideUI;
property OnUpdateUI: TUpdateUIEvent read FOnUpdateUI write FOnUpdateUI;
property OnEnableModeless: TEnableModelessEvent read FOnEnableModeless write FOnEnableModeless;
property OnOnDocWindowActivate: TOnDocWindowActivateEvent read FOnOnDocWindowActivate write FOnOnDocWindowActivate;
property OnOnFrameWindowActivate: TOnFrameWindowActivateEvent read FOnOnFrameWindowActivate write FOnOnFrameWindowActivate;
property OnResizeBorder: TResizeBorderEvent read FOnResizeBorder write FOnResizeBorder;
property OnTranslateAccelerator: TTranslateAcceleratorEvent read FOnTranslateAccelerator write FOnTranslateAccelerator;
property OnGetOptionKeyPath: TGetOptionKeyPathEvent read FOnGetOptionKeyPath write FOnGetOptionKeyPath;
property OnGetDropTarget: TGetDropTargetEvent read FOnGetDropTarget write FOnGetDropTarget;
property OnGetExternal: TGetExternalEvent read FOnGetExternal write FOnGetExternal;
property OnTranslateUrl: TTranslateUrlEvent read FOnTranslateUrL write FOnTranslateUrL;
property OnFilterDataObject: TFilterDataObjectEvent read FOnFilterDataObject write FOnFilterDataObject;
property HelpFile: string read FHelpFile write FHelpFile;
property OnShowMessage: TShowMessageEvent read FOnShowMessage write FOnShowMessage;
property OnShowHelp: TShowHelpEvent read FOnShowHelp write FOnShowHelp;
property OnGetTypeInfoCount: TGetTypeInfoCountEvent read FonGetTypeInfoCount write FOnGetTypeInfoCount;
property OnGetTypeInfo: TGetTypeInfoEvent read FonGetTypeInfo write FOnGetTypeInfo;
property OnGetIDsOfNames: TGetIDsOfNamesEvent read FOnGetIDsOfNames write FOnGetIdsOfNames;
property OnInvoke: TInvokeEvent read FOnInvoke write FOnInvoke;
property OnQueryService: TQueryServiceEvent read FOnQueryService write FOnQueryService;
property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery;
property OnShowDialog: TShowDialogEvent read FOnShowDialog write FOnShowDialog;
property PrintOptions: TPrintOptions read FPrintOptions write FPrintOptions;
property UserAgent: string read FUserAgent write FUserAgent;
property ReplaceCaption: Boolean read FReplaceCaption write FReplaceCaption;
property EnableDDE: Boolean read FEnableDDE write FEnableDDE;
property fpExceptions: Boolean read FfpExceptions write SetfpExceptions;
end;
function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
function RegisterNameSpace(clsid: TGUID): HRESULT;
function UnregisterNameSpace: HRESULT;
procedure Register;
implementation
uses comobj;
var
Saved8087CW: Word;
PrintingWithOptions: Boolean;
InvokingPagesetup: Boolean;
MimeFactory, NSFactory: IClassFactory;
MimeInternetSession, NSInternetSession: IInternetSession;
DontRespond: Boolean;
OpenFolder, ExploreFolder: string;
FoldersApp, FoldersTopic: string;
FindFolder: string;
HtmlFileApp, HtmlFileTopic: string;
fHtmlCommand: Boolean;
{$IFDEF VER120}
bMsgHandler: Boolean;
{$ENDIF}
procedure TEmbeddedWB.GetThumbnail(var Image: TImage);
var
DrawRect: TRect;
begin
if Image = nil then exit;
DrawRect := Rect(0, 0, Image.Height, Image.width);
Image.Picture.Bitmap.Height := image.height;
Image.Picture.Bitmap.Width := image.Width;
({$IFDEF VER120}Application_{$ELSE}Application{$ENDIF} as IviewObject).Draw(DVASPECT_DOCPRINT, 0, nil, nil, 0,
image.Canvas.Handle, @DrawRect, nil, nil, 0);
Image.Refresh;
end;
procedure TEmbeddedWB.SetfpExceptions(const Value: Boolean);
begin
if not Value then begin
Set8087CW($133F);
FfpExceptions := False;
end
else
begin
Set8087CW(Saved8087CW);
FfpExceptions := True;
end;
end;
function TEmbeddedwb.GetFrame(FrameNo: Integer): IWebbrowser2;
var
OleContainer: IOleContainer;
enum: IEnumUnknown;
unk: IUnknown;
Fetched: PLongint;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(document) then
begin
Fetched := nil;
OleContainer := Document as IOleContainer;
OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
Enum.Skip(FrameNo);
Enum.Next(1, Unk, Fetched);
Result := Unk as IWebbrowser2;
end else Result := nil;
end;
{
Ver. 1.16:
Thanks to Brian Lowe for Fixing OLE-problem in function FrameCount:
http://groups.yahoo.com/group/delphi-webbrowser/message/4194
}
function TEmbeddedWB.FrameCount: LongInt;
var
OleContainer: IOleContainer;
enum: IEnumUnknown;
unk: array[0..99] of IUnknown; // CHANGED from "unk: IUnknown;"
EnumResult: HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(document) then
begin
OleContainer := Document as IOleContainer;
EnumResult := OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
if EnumResult = S_OK then // Added per OLE help
Enum.Next(100, Unk, @Result)
else // Added per OLE help
Enum := nil;
end else
Result := 0;
end;
procedure TEmbeddedWB.SetUserAgent;
var
reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('/Software/Microsoft/Windows/CurrentVersion/Internet Settings/User Agent/Post Platform', True)
then Reg.WriteString(FUserAgent, '');
finally
Reg.CloseKey;
Reg.Free;
end;
end;
procedure TEmbeddedWB.RemoveUserAgent;
var
reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('/Software/Microsoft/Windows/CurrentVersion/Internet Settings/User Agent/Post Platform', FALSE)
then reg.DeleteValue(FUseragent);
finally
Reg.CloseKey;
Reg.Free;
end;
end;
function GetDDEVariables: Boolean;
var
s: string;
Reg: TRegistry;
begin
Reg := Tregistry.Create;
with Reg do try
RootKey := HKEY_CLASSES_ROOT;
OpenKey('htmlfile/shell/open/ddeexec/application', False);
HtmlFileApp := Readstring('');
CloseKey;
OpenKey('htmlfile/shell/open/ddeexec/topic', FALSE);
HtmlFileTopic := ReadString('');
CloseKey;
OpenKey('Folder/shell/open/ddeexec/application', False);
FoldersApp := Readstring('');
CloseKey;
OpenKey('Folder/shell/open/ddeexec/topic', FALSE);
FoldersTopic := ReadString('');
CloseKey;
OpenKey('Folder/shell/open/ddeexec', False);
s := readString('');
CloseKey;
S := Copy(S, Pos('[', S) + 1, length(S));
OpenFolder := Copy(s, 1, Pos('(', S) - 1);
OpenKey('Folder/shell/explore/ddeexec', False);
s := readString('');
CloseKey;
S := Copy(S, Pos('[', S) + 1, length(S));
ExploreFolder := Copy(s, 1, Pos('(', S) - 1);
OpenKey('Directory/shell/find/ddeexec', False);
s := readString('');
CloseKey;
S := Copy(S, Pos('[', S) + 1, length(S));
FindFolder := Copy(s, 1, Pos('(', S) - 1);
Result := True;
except
Result := False;
end;
Reg.Free;
end;
function GetCommandTypeFromDDEString(szCommand: string): UINT;
begin
szCommand := Copy(szCommand, Pos('[', szCommand) + 1, length(szCommand));
szCommand := Copy(szCommand, 1, Pos('(', szCommand) - 1);
if szCommand = Openfolder then Result := VIEW_COMMAND else
if szCommand = Explorefolder then Result := EXPLORE_COMMAND else
if szCommand = Findfolder then Result := FIND_COMMAND else
Result := NO_COMMAND;
end;
function GetPathFromDDEString(szCommand: string; var szFolder: string): Boolean;
begin
szCommand := Copy(szCommand, Pos('"', szCommand) + 1, length(szCommand));
szFolder := Copy(szCommand, 1, Pos('"', szCommand) - 1);
Result := (szFolder <> '');
end;
function GetPidlFromDDEString(szCommand: string): PItemIDList;
var
pidlShared, pidlGlobal: PItemIDList;
dwProcessID: Integer;
hShared: THandle;
s: string;
ProcessID: string;
i: Integer;
begin
s := Copy(szCommand, Pos(',', szCommand) + 1, length(szCommand));
i := 1;
while not (s in IsDigit) and (i <= Length(s)) do Inc(i);
processID := Copy(s, i, Length(S));
s := copy(S, i, length(s) - 1);
i := 1;
while (s in IsDigit) and (i <= Length(s)) do Inc(i);
s := copy(S, 1, i - 1);
while not ((ProcessID = ':') or (ProcessID = ',')) and (i <= Length(processID)) do Inc(i);
if ProcessID = ':' then
begin
ProcessID := Copy(ProcessID, i, Length(ProcessID));
i := 1;
while not (ProcessID in IsDigit) and (i <= Length(ProcessID)) do Inc(i);
ProcessID := Copy(ProcessID, i, Length(ProcessID));
i := 1;
while (ProcessID in IsDigit) and (i <= Length(ProcessID)) do Inc(i);
if not (ProcessID in IsDigit) then ProcessID := Copy(ProcessID, 1, i - 1);
end else ProcessID := '0';
dwProcessID := StrToInt(ProcessID);
if dwProcessID <> 0 then begin
hShared := StrToInt(s);
pidlShared := ShLockShared(hShared, dwProcessId);
if PidlShared <> nil then
begin
Result := CopyPidl(PidlShared);
ShUnlockShared(pidlShared);
end else Result := nil;
ShFreeShared(hShared, dwProcessID);
end else
begin
pidlGlobal := PItemIDList(StrToInt(s));
Result := CopyPidl(pidlGlobal);
_Free(pidlGlobal);
end;
end;
function GetShowCmdFromDDEString(szCommand: string): Integer;
var
i: Integer;
begin
i := 1;
while szCommand <> ',' do Inc(i);
Inc(i);
while szCommand <> ',' do Inc(i);
szCommand := Copy(szCommand, i, Length(szCommand));
i := 0;
repeat
inc(i)
until (i > Length(szCommand)) or (szCommand in IsDigit);
if i <= length(szCommand) then result := StrtoInt(szCommand) else
result := 1;
end;
function ParseDDECommand(szCommand: string; var szFolder: string; var pidl: PItemIDList; var show: Integer): UINT;
begin
Result := GetCommandTypeFromDDEString(szCommand);
if Result <> NO_COMMAND then begin
GetPathFromDDEString(szCommand, szFolder);
pidl := GetPidlFromDDEString(szCommand);
Show := GetShowCmdFromDDEString(szCommand);
end;
end;
function TEmbeddedwb.DDETerminate(iwParam: WPARAM; ilParam: LPARAM): BOOL;
begin
Result := PostMessage(THandle(iwParam), WM_DDE_TERMINATE, handle, 0);
end;
function TEmbeddedWB.DDEInitiate(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
var
dwThreadID: DWORD;
dwProcessID: DWORD;
hwndClient: Integer;
aInApp,
aInTopic,
aOutApp,
aOutTopic: ATOM;
szInAppName,
szInAppTopic: array[0..255] of Char;
begin
FillChar(szInAppName, SizeOf(szInAppName), 0);
FillChar(szInAppTopic, SizeOf(szInAppTopic), 0);
if DontRespond then
begin
result := 0;
exit;
end;
hwndClient := THandle(iwParam);
dwThreadID := GetWindowThreadProcessId(hwndClient, @dwProcessID);
if (GetCurrentProcessId() <> dwProcessID) or (GetCurrentThreadID() <> dwThreadID) then
begin
result := 0;
exit;
end;
aInApp := LOWORD(ilParam);
aInTopic := HIWORD(ilParam);
GlobalGetAtomName(aInApp, szInAppName, SizeOf(szInAppName));
GlobalGetAtomName(aInTopic, szInAppTopic, SizeOf(szInAppTopic));
if szInAppName = HtmlFileApp then
begin
fHtmlCommand := True;
aOutApp := GlobalAddAtom(PChar(HtmlFileApp));
aOutTopic := GlobalAddAtom(PChar(HtmlFileTopic));
if ((aOutApp <> 0) and (aOutTopic <> 0) and (aOutApp = aInApp) and (aOutTopic = aInTopic)) then
SendMessage(hwndClient, WM_DDE_ACK, WPARAM(handle), MAKELPARAM(aOutApp, aOutTopic));
if (aOutApp <> 0) then GlobalDeleteAtom(aOutApp);
if (aOutTopic <> 0) then GlobalDeleteAtom(aOutTopic);
end
else
begin
fHtmlCommand := False;
aOutApp := GlobalAddAtom(PChar(FoldersApp));
aOutTopic := GlobalAddAtom(PChar(FoldersTopic));
if ((aOutApp <> 0) and (aOutTopic <> 0) and (aOutApp = aInApp) and (aOutTopic = aInTopic)) then
SendMessage(HWNDClient, WM_DDE_ACK, WPARAM(Handle), MAKELPARAM(aOutApp, aOutTopic));
if (aOutApp <> 0) then GlobalDeleteAtom(aOutApp);
if (aOutTopic <> 0) then GlobalDeleteAtom(aOutTopic);
end;
result := 0;
end;
function TEmbeddedwb.DDEExecute(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
var
szFolder: string;
szCommand: LPTSTR;
uLo: PUINT;
hgMem: HGLOBAL;
ack: DDEACK;
lpTemp: PUINT;
uCommand: Cardinal;
show: Integer;
pidl: PITEMIDLIST;
sei: TShellExecuteInfo;
szTmp: string;
begin
ulo := nil;
if UnpackDDElParam(WM_DDE_EXECUTE, ilParam, uLo, @hgMem)
then begin
szCommand := GlobalLock(hgmem);
ZeroMemory(@Ack, sizeof(ddeAck));
if (szCommand <> nil) then
begin
if fHtmlCommand then
begin
szTmp := szCommand;
if Pos('"', szTmp) = 1 then
begin
Delete(szTmp, 1, 1);
szTmp := System.Copy(szTmp, 1, Pos('"', szTmp) - 1);
end;
Go(szTmp);
Ack.flags := 1;
end
else
begin
uCommand := ParseDDECommand(szCommand, szFolder, pidl, Show);
case uCommand of
VIEW_COMMAND:
begin
if (szFolder <> '') then Go(szFolder)
else
if (pidl <> nil) then NavigatePidl(pidl);
DisposePidl(pidl);
Ack.flags := 1;
end;
EXPLORE_COMMAND:
begin
DontRespond := TRUE;
ZeroMemory(@sei, sizeof(SHELLEXECUTEINFO));
sei.cbSize := sizeof(SHELLEXECUTEINFO);
if szFolder <> '' then begin
sei.fMask := SEE_MASK_CLASSNAME;
sei.lpFile := Pchar(szFolder);
end else
begin
sei.fMask := SEE_MASK_IDLIST or SEE_MASK_CLASSNAME;
sei.lpIDList := pidl;
end;
sei.lpClass := 'folder';
sei.Wnd := 0;
sei.nShow := Show;
sei.lpVerb := 'explore';
ShellExecuteEx(@sei);
DontRespond := FALSE;
DisposePidl(pidl);
Ack.flags := 1;
end;
FIND_COMMAND:
begin
DontRespond := TRUE;
ZeroMemory(@sei, sizeof(SHELLEXECUTEINFO));
sei.cbSize := sizeof(SHELLEXECUTEINFO);
if (szFolder <> '')
then begin
sei.fMask := 0;
sei.lpFile := PChar(szFolder);
end
else
begin
sei.fMask := SEE_MASK_IDLIST;
sei.lpIDList := pidl;
end;
sei.wnd := 0;
sei.nShow := Show;
sei.lpVerb := 'find';
ShellExecuteEx(@sei);
DontRespond := FALSE;
DisposePidl(pidl);
Ack.flags := 1;
end;
end;
end;
GlobalUnlock(hgMem);
lpTemp := @Ack;
PostMessage(Thandle(iwParam),
WM_DDE_ACK,
WPARAM(handle),
ReuseDDElParam(ilParam, WM_DDE_EXECUTE, WM_DDE_ACK, lpTemp^, hgMem));
end;
end;
Result := 0;
end;
procedure TEmbeddedwb.PrintWithOptions;
begin
PrintingWithOptions := True;
Pagesetup(TRUE);
Print;
end;
procedure TembeddedWB.GetPrintValues;
var
S: string;
regWinRegistry: TRegistry;
function ReadMargin(key: string): Real;
begin
S := RegwinRegistry.ReadString(key);
S := Stringreplace(S, ' ', '', [rfReplaceAll]);
if DecimalSeparator <> '.' then
S := Stringreplace(S, '.', DecimalSeparator, []);
if Printoptions.Measure = mMetric then
result := StrtoFloat(S) * InchToMetric else
result := StrtoFloat(S);
end;
begin
regWinRegistry := TRegistry.Create;
try
with regWinRegistry do begin
RootKey := HKEY_CURRENT_USER;
if OpenKey('Software/Microsoft/Internet Explorer/PageSetup', False) then
begin
PrintOptions.Header := Readstring('header');
PrintOptions.Footer := ReadString('footer');
PrintOptions.Margins.left := ReadMargin('margin_left');
PrintOptions.Margins.right := ReadMargin('margin_right');
PrintOptions.Margins.top := ReadMargin('margin_top');
PrintOptions.Margins.bottom := ReadMargin('margin_bottom');
end;
end;
finally
regWinRegistry.Free;
end;
end;
procedure TEmbeddedWB.Loaded;
begin
inherited Loaded;
CoInternetCreateSecuritymanager(self, SecurityManager, 0);
CoInternetCreateZoneManager(self, ZoneManager, 0);
UpdateDownloadControlValue;
UpdateUserInterfaceValue;
hook;
if not (csDesigning in ComponentState) then
begin
OldWBWndProc := WindowProc;
WindowProc := WBWndProc;
SetUserAgent;
end else
begin
PrintOptions.FMeasure := RunTimeMeasure;
GetPrintValues;
end;
end;
function TEmbeddedWB.PrintMarginStr(M: Real): PChar;
var
S: string;
begin
if printOptions.Measure <> RuntimeMeasure
then begin
if RuntimeMeasure = mMetric then
s := FloatToStr(M * InchToMetric) else
s := FloatToStr(M / InchToMetric);
Result := PChar(S);
end else Result := PChar(FloatToStr(M));
end;
constructor TEmbeddedWb.Create(Owner: TComponent);
var
Buf: array[1..10] of Char;
begin
FfpExceptions := True;
inherited;
{$IFDEF VER120}
enablemessagehandler;
{$ENDIF}
GetDDEVariables;
DDEHWnd := AllocateHWnd(DDEWndProc);
FPrintOptions := TPrintOptions.Create;
FPrintOptions.Margins := TMargins.Create;
FPrintOptions.FHTMLHeader := TStringlist.Create;
FPrintOptions.FHTMLHeader.Add('<HTML></HTML>');
FillChar(Buf, SizeOf(Buf), 0);
GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IMEASURE, @Buf[1], SizeOf(Buf));
if Buf[1] = '1' then RunTimeMeasure := mUS else
RunTimeMeasure := mMetric;
DownloadOptions := [DLCTL_DLIMAGES, DLCTL_BGSOUNDS, DLCTL_VIDEOS];
UserInterfaceOptions := [];
FEnableDDE := False;
end;
destructor TEmbeddedWb.Destroy;
begin
DeAllocateHWnd(DDEHwnd);
FPrintOptions.HTMLHeader.Free;
FPrintoptions.Margins.Free;
FPrintoptions.Free;
unhook;
RemoveUserAgent;
{$IFDEF VER120}
disablemessagehandler;
{$ENDIF}
inherited;
end;
function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
begin
CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, MimeFactory);
CoInternetGetSession(0, MimeInternetSession, 0);
Result := MIMEInternetSession.RegisterMimeFilter(MimeFactory, Clsid, MIME);
end;
function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
begin
Result := MIMEInternetSession.UnregisterMimeFilter(MIMEFactory, MIME);
end;
function RegisterNameSpace(clsid: TGUID): HRESULT;
begin
CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, NSFactory);
CoInternetGetSession(0, NSInternetSession, 0);
Result := NSInternetSession.RegisterNameSpace(NSFactory, Clsid, 'http', 0, nil, 0);
end;
function UnregisterNameSpace: HRESULT;
begin
Result := NSInternetSession.UnregisterNameSpace(NSFactory, 'http');
end;
procedure TEmbeddedWB.Hook;
begin
if (csDesigning in ComponentState) then exit;
FParentform := TForm(Owner);
if (FParentForm <> nil) and (FParentForm.HandleAllocated) then
begin
FOldWindowProc := FParentForm.WindowProc;
FParentForm.WindowProc := FormWndProc;
end;
end;
procedure TEmbeddedWB.UnHook;
begin
if (csDesigning in ComponentState) then exit;
if (FParentForm <> nil) and (FParentForm.HandleAllocated) then
FParentForm.WindowProc := FOldWindowProc;
// FOldWindowProc := nil;
FParentform := nil;
end;
procedure TEmbeddedWB.DDEWndProc(var AMsg: TMessage);
begin
with AMsg do
if (Msg = WM_DDE_INITIATE) and FEnableDDE
then DDEInitiate(wparam, lparam)
else
Result := DefWindowProc(DDEHWND, msg, wParam, lParam);
end;
procedure TEmbeddedWB.FormWndProc(var AMsg: TMessage);
var
i: Integer;
wnd: Integer;
S: string;
Msg: TWmActivate;
begin
if AMsg.Msg = WM_ACTIVATE then begin
Msg := TWmActivate(AMsg);
if Msg.Active = 0 then
begin
wnd := Msg.ActiveWindow;
SetLength(S, 80);
SetLength(S, GetClassName(Wnd, PChar(S), Length(S)));
if (S = '#32770') then
begin
if ReplaceCaption then
begin
SendMessage(wnd, WM_SETICON, ICON_SMALL, Forms.Application.Icon.Handle);
I := GetWindowTextLength(wnd);
SetLength(S, I + 1);
GetWindowText(Wnd, PChar(S), I + 1);
S := StringReplace(S, 'Microsoft ', '', []);
S := StringReplace(S, 'Internet Explorer', Forms.Application.Title, []);
SetWindowText(Wnd, Pchar(S));
end;
if InvokingPageSetup then
begin
InvokingPagesetup := False;
if PrintingWithOptions then
begin
SetWindowPos(Wnd, 0, -600, 0, 0, 0, 0);
PrintingWithOptions := False;
end;
if PrintOptions.Orientation = poPortrait then
SendDlgItemMessage(Wnd, $0420, BM_CLICK, 0, 0) else
SendDlgItemMessage(Wnd, $0421, BM_CLICK, 0, 0);
SetDlgItemText(wnd, $1FD3, PChar(PrintOptions.Header));
SetDlgItemText(wnd, $1FD5, PChar(PrintOptions.Footer));
SetDlgItemText(wnd, $0483, PrintMarginStr(PrintOptions.Margins.Left));
SetDlgItemText(wnd, $0484, PrintMarginStr(PrintOptions.Margins.top));
SetDlgItemText(wnd, $0485, PrintMarginStr(PrintOptions.Margins.Right));
SetDlgItemText(wnd, $0486, PrintMarginStr(PrintOptions.Margins.Bottom));
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4) then
PostMessage(FindWindowEx(wnd, 0, Pchar('Button'), nil), BM_CLICK, 0, 0) //Win2000
else SendDlgItemMessage(Wnd, 1, BM_CLICK, 0, 0);
end;
end;
if not PrintingWithOptions and (wnd <> 0) and Assigned(FOnShowDialog) then FOnShowDialog(self, Wnd);
end;
end;
FOldWindowProc(AMsg);
end;
function TEmbeddedWB.QueryService(const rsid, iid: TGuid; out Obj): HResult;
begin
if Assigned(FOnQueryService) then
Result := FOnQueryService(rsid, iid, IUnknown(obj)) else
Result := E_NOINTERFACE;
end;
function TEmbeddedWB.ShowMailClient: Boolean;
begin
result := OpenClient('Mail');
end;
function TEmbeddedWB.ShowNewsClient: Boolean;
begin
result := OpenClient('News');
end;
function TEmbeddedWB.ShowAddressBook: Boolean;
begin
result := OpenClient('Contacts');
end;
function TEmbeddedWB.ShowCalendar: Boolean;
begin
result := OpenClient('Calendar');
end;
function TEmbeddedWB.ShowInternetCall: Boolean;
begin
result := OpenClient('Internet Call');
end;
function TEmbeddedWB.OpenClient(Client: string): Boolean;
var
s, params, Exec: string;
begin
Result := FALSE;
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('Software/Clients/' + Client, FALSE);
S := ReadString('');
CloseKey;
OpenKey('Software/Clients/' + Client + '/' + S + '/shell/open/command', FALSE);
S := ReadString('');
CloseKey;
if S <> '' then begin
if Pos('/', S) > 0 then begin
Exec := system.Copy(S, 1, Pos('/', S) - 2);
Params := system.Copy(s, Length(exec) + 1, length(S));
end else begin
Exec := S;
Params := '';
end;
Result := TRUE;
shellExecute(handle, 'open', Pchar(Exec), pChar(Params), '', SW_SHOW);
end;
finally
Free;
end;
end;
procedure TEmbeddedWB.PrintPreView;
// IE 5.5 only
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.SetDownloadOptions(const Value:
TDownloadControlOptions);
begin
FDownloadControlOptions := Value;
UpdateDownloadControlValue;
{$IFDEF VER120}
(Application_ as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ELSE}
(Application as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ENDIF}
end;
procedure TEmbeddedWB.SetUserInterfaceOptions(const Value:
TUserInterfaceOptions);
begin
FUserInterfaceOptions := Value;
UpdateUserInterfaceValue;
{$IFDEF VER120}
(Application_ as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ELSE}
(Application as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ENDIF}
end;
procedure TEmbeddedWB.UpdateDownloadControlValue;
const
acardDownloadControlValues: array[TDownloadControlOption] of Cardinal =
($00000010, $00000020, $00000040, $00000080,
$00000100, $00000200, $00000400, $00000800,
$00001000, $00002000, $00004000, $00008000,
$00010000, $00020000, $00040000, $10000000,
$20000000, $40000000, $80000000);
var
i: TDownloadControlOption;
begin
FDownloadOptionValue := 0;
if (FDownloadControlOptions <> []) then
for i := Low(TDownloadControlOption) to High(TDownloadControlOption)
do
if (i in FDownloadControlOptions) then
Inc(FDownloadOptionValue, acardDownloadControlValues);
end;
procedure TEmbeddedWB.UpdateUserInterfaceValue;
const
acardUserInterfaceValues: array[TUserInterfaceOption] of Cardinal =
($00000001, $00000002, $00000004, $00000008,
$00000010, $00000020, $00000040, $00000080,
$00000100, $00000200, $00000400, $00000800,
$00001000, $00002000, $00004000, $00010000, $00020000);
var
i: TUserInterfaceOption;
begin
FUserInterfaceValue := 0;
if (FUserInterfaceOptions <> []) then
for i := Low(TUserInterfaceOption) to High(TUserInterfaceOption) do
if (i in FUserInterfaceOptions) then
Inc(FUserInterfaceValue, acardUserInterfaceValues);
end;
function TEmbeddedWB.IsGlobalOffline: boolean;
var
dwState: DWORD;
dwSize: DWORD;
begin
dwState := 0;
dwSize := SizeOf(dwState);
result := false;
if (InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @dwState,
dwSize)) then
if ((dwState and INTERNET_STATE_DISCONNECTED_BY_USER) <> 0) then
result := true;
end;
procedure TEmbeddedWB.SetGlobalOffline(Value: Boolean);
const
INTERNET_STATE_DISCONNECTED_BY_USER = $10;
ISO_FORCE_DISCONNECTED = $1;
INTERNET_STATE_CONNECTED = $1;
var
ci: TInternetConnectedInfo;
dwSize: DWORD;
begin
dwSize := SizeOf(ci);
if (Value) then begin
ci.dwConnectedState := INTERNET_STATE_DISCONNECTED_BY_USER;
ci.dwFlags := ISO_FORCE_DISCONNECTED;
end else begin
ci.dwFlags := 0;
ci.dwConnectedState := INTERNET_STATE_CONNECTED;
end;
InternetSetOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ci, dwSize);
end;
function SaveDocToStream(Doc: IDispatch; var AStream: TStream): HResult;
var
IpStream: IPersistStreamInit;
begin
if Doc <> nil then begin
IpStream := Doc as IPersistStreamInit;
Result := IpStream.save(TStreamAdapter.Create(AStream), TRUE);
end else Result := S_FALSE;
end;
function TEmbeddedWB.SaveToStream(AStream: TStream): HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(Document) then
Result := SaveDocToStream(Document, AStream)
else Result := S_FALSE;
end;
function SaveDocToStrings(Doc: IDispatch; var AStrings: TStrings): HResult;
var
IpStream: IPersistStreamInit;
AStream: TMemoryStream;
begin
AStream := TMemoryStream.Create;
try
IpStream := doc as IPersistStreamInit;
if not Assigned(IpStream) then Result := S_FALSE else
if Succeeded(IpStream.save(TStreamadapter.Create(AStream), TRUE))
then begin
AStream.Seek(0, 0);
AStrings.LoadFromStream(AStream);
Result := S_OK;
end else Result := S_FALSE;
except
Result := S_FALSE;
end;
AStream.Free;
end;
function TEmbeddedwb.SaveFrameToStream(FrameNo: Integer; AStream: TStream): HRESULT;
var
iw: IWebbrowser2;
begin
Result := S_FALSE;
iw := Getframe(frameNo);
if (iw <> nil) and assigned(iw.Document) then
Result := SaveDocToStream(iw.Document, AStream)
end;
function TEmbeddedwb.SaveFrameToStrings(FrameNo: Integer; AStrings: TStrings): HRESULT;
var
iw: Iwebbrowser2;
begin
Result := S_FALSE;
iw := Getframe(frameNo);
if (iw <> nil) and assigned(iw.Document) then
Result := SaveDocToStrings(iw.Document, AStrings);
end;
function TEmbeddedwb.SaveFrameToFile(FrameNo: Integer; const Fname: string): HRESULT;
var
Iw: IWebbrowser2;
PFile: IPersistFile;
begin
iw := Getframe(frameNo);
if (iw <> nil) and assigned(iw.Document) then begin
PFile := iw.Document as IPersistFile;
Result := PFile.Save(StringToOleStr(FName), False);
end else Result := S_FALSE;
end;
function SaveDocToFile(Doc: IDispatch; const Fname: string): HResult;
var
PFile: IPersistFile;
begin
PFile := Doc as IPersistFile;
Result := PFile.Save(StringToOleStr(FName), False);
end;
function TEmbeddedWB.SaveToFile(const Fname: string): HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(Document) then
begin
Result := SaveDocToFile(Document, FName);
end else Result := S_FALSE;
end;
function TEmbeddedWB.SaveToStrings(AStrings: TStrings): HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(document) then
Result := SaveDocToStrings(Document, AStrings)
else Result := S_FALSE;
end;
function TEmbeddedWb.LoadFrameFromStrings(Frameno: Integer; const AStrings: TStrings): HResult;
var
iw: IWebbrowser2;
M: TMemoryStream;
begin
Result := S_FALSE;
iw := GetFrame(Frameno);
if (iw <> nil) and assigned(iw.document) then begin
M := TMemoryStream.Create;
try
AStrings.SaveToStream(M);
M.seek(0, 0);
Result := (iw.Document as IPersistStreamInit).Load(TStreamadapter.Create(M));
except
Result := S_FALSE;
end;
M.free;
end;
end;
function TEmbeddedWb.LoadFromStrings(const AStrings: TStrings): HResult;
var
M: TMemoryStream;
begin
if not Assigned(document) then AssignDocument;
M := TMemoryStream.Create;
try
AStrings.SaveToStream(M);
Result := LoadFromStream(M);
except
Result := S_FALSE;
end;
M.free;
end;
function TEmbeddedWb.LoadFrameFromStream(FrameNo: Integer; AStream: TStream): HRESULT;
var
iw: IWebbrowser2;
begin
Result := S_FALSE;
iw := Getframe(frameNo);
if (iw <> nil) then if Assigned(iw.Document) then
begin
AStream.seek(0, 0);
Result := (iw.Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream));
end;
end;
function TEmbeddedWb.LoadFromStream(const AStream: TStream): HRESULT;
begin
if not Assigned(Document) then AssignDocument;
AStream.seek(0, 0);
Result := (Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream));
end;
procedure TEmbeddedWb.AssignDocument;
begin
Go('about:blank');
while readystate <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages;
end;
procedure TEmbeddedWb.SetFocusToDoc;
begin
if Document <> nil then
with {$IFDEF VER120}Application_{$ELSE}Application{$ENDIF} as IOleobject do
DoVerb(OLEIVERB_UIACTIVATE, nil, Self, 0, Handle, GetClientRect);
end;
{$IFDEF VER120}
procedure TEmbeddedWb.EnableMessagehandler;
begin
if not bMsgHandler then
begin
SaveMessage := Forms.Application.OnMessage;
Forms.Application.OnMessage := IeMessagehandler;
bMsgHandler := True;
end;
end;
procedure TEmbeddedWB.DisableMessageHandler;
begin
if bMsgHandler then
begin
Forms.Application.onMessage := Savemessage;
bMsgHandler := False;
end;
end;
{$ENDIF}
///BEGIN >>>>> Messagehandler by Mathias Walter - walter@coint.de >>>>>///
procedure TEmbeddedWB.WBWndProc(var Message: TMessage);
const
StdKeys = [VK_RETURN, VK_BACK]; { standard keys }
ExtKeys = [VK_LEFT, VK_RIGHT]; { extended keys }
fExtended = $01000000; { extended key flag }
var
bClose: Boolean;
{$IFNDEF VER120}
WinMsg: TMsg;
{$ENDIF}
begin
with Message do
begin
{$IFNDEF VER120}
if (Msg >= (CN_BASE + WM_KEYFIRST)) and (Msg <= (CN_BASE + WM_DEADCHAR)) then
begin
WinMsg.hwnd := Handle;
WinMsg.message := Msg - CN_BASE;
WinMsg.wParam := wParam;
WinMsg.lParam := lParam;
WinMsg.time := GetMessageTime;
WinMsg.pt.x := $115DE1F1;
WinMsg.pt.y := $115DE1F1;
if not ((wParam in StdKeys) or
(wParam in ExtKeys) and ((lParam and fExtended) = fExtended)) then
with Application as IOleInPlaceActiveObject do
Result := Integer(TranslateAccelerator(WinMsg) = S_OK);
end
else
{$ENDIF}
case Msg of
WM_CLOSE: begin
bClose := True;
if Assigned(FOnCloseQuery) then
FOnCloseQuery(Self, bClose);
if bClose then
OldWBWndProc(Message);
end;
WM_DDE_EXECUTE: DDEExecute(wparam, lparam);
WM_DDE_TERMINATE: DDETerminate(wparam, lparam);
else
OldWBWndProc(Message);
end;
end;
end;
{$IFDEF VER120}
procedure TEmbeddedWB.IEMessageHandler(var Msg: TMsg; var Handled: Boolean);
{ fixes the malfunction of some keys within webbrowser control }
const
StdKeys = [VK_TAB, VK_RETURN]; { standard keys }
ExtKeys = [VK_DELETE, VK_BACK, VK_LEFT, VK_RIGHT]; { extended keys }
fExtended = $01000000; { extended key flag }
begin
Handled := False;
with Msg do
if ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) and
((wParam in StdKeys) or (GetKeyState(VK_CONTROL) < 0) or
(wParam in ExtKeys) and ((lParam and fExtended) = fExtended)) then
try
if IsChild(Handle, hWnd) then
{ handles all browser related messages }
begin
with Application_ as IOleInPlaceActiveObject do
Handled := TranslateAccelerator(Msg) = S_OK;
if not Handled then
begin
Handled := True;
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
except end;
end; // IEMessageHandler
{$ENDIF}
///END <<<<<< Messagehandler by Mathias Walter - walter@coint.de <<<<<///
procedure TEmbeddedWb.NavigateFolder(CSIDL: Integer);
var
sFolder: PITemIdList;
begin
SHGetSpecialFolderLocation(0, CSIDL, SFolder);
NavigatePidl(SFolder);
CoTaskMemFree(SFolder);
end;
procedure TEmbeddedWB.NavigatePidl(pidl: PItemIdList);
var
VaEmpty, vaPidl: Olevariant;
psa: PSafeArray;
cbData: UINT;
begin
cbdata := GetPidlSize(pidl);
psa := SafeArrayCreateVector(VT_UI1, 0, cbData);
if (psa <> nil) then begin
CopyMemory(psa.pvData, pidl, cbData);
VariantInit(vaPidl);
TVariantArg(vaPidl).vt := VT_ARRAY or VT_UI1;
TVariantArg(vaPidl).parray := psa;
Navigate2(vaPidl, vaEmpty, vaEmpty, vaEmpty, vaEmpty);
VariantClear(vaPidl);
end;
end;
procedure TEmbeddedWB.Go(Url: string);
var
_URL, Flags, TargetFrameName, PostData, Headers: Olevariant;
begin
_URL := Url;
Flags := 0; TargetFrameName := 0; Postdata := 0; Headers := 0;
Navigate2(_URL, Flags, TargetFrameName, PostData, Headers);
end;
procedure TEmbeddedWB.InvokeCMD(InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant);
var
CmdTarget: IOleCommandTarget;
PtrGUID: PGUID;
begin
New(PtrGUID);
if InvokeIE then PtrGUID^ := CLSID_WebBrowser else
PtrGuid := PGUID(nil);
if Document <> nil then
try
Document.QueryInterface(IOleCommandTarget, CmdTarget);
if CmdTarget <> nil then
try
CmdTarget.Exec(PtrGuid, Value1, Value2, vaIn, vaOut);
finally
CmdTarget._Release;
end;
except end;
Dispose(PtrGUID);
end;
procedure TEmbeddedWB.Print;
var
vaIn, vaOut: Olevariant;
HtmlText: string;
Stream: IStream;
Dummy: Int64;
Psa: PSafeArray;
begin
HtmlText := PrintOptions.HtmlHeader.Text;
CreateStreamOnHGlobal(0, TRUE, Stream);
Stream.Write(Pchar(HTMLText), length(HTMLText), @Dummy);
Stream.Seek(0, STREAM_SEEK_SET, Dummy);
SafeArrayCopy(PSafeArray(TVarData(VarArrayOf([FPrintOptions.Header, FPrintOptions.Footer, Stream as IUnknown])).VArray), psa);
TVarData(VaIn).VType := varArray or varByRef;
SafeArrayCopy(psa, PSafeArray(TVarData(VaIn).VArray));
InvokeCmd(FALSE, OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;
procedure TEmbeddedWB.PrintSetup;
var
vaIn, vaOut: Olevariant;
HtmlText: string;
Stream: IStream;
Dummy: Int64;
Psa: PSafeArray;
begin
HtmlText := PrintOptions.HtmlHeader.Text;
CreateStreamOnHGlobal(0, TRUE, Stream);
Stream.Write(Pchar(HTMLText), length(HTMLText), @Dummy);
Stream.Seek(0, STREAM_SEEK_SET, Dummy);
SafeArrayCopy(PSafeArray(TVarData(VarArrayOf([FPrintOptions.Header, FPrintOptions.Footer, Stream as IUnknown])).VArray), psa);
TVarData(VaIn).VType := varArray or varByRef;
SafeArrayCopy(psa, PSafeArray(TVarData(VaIn).VArray));
InvokeCmd(FALSE, OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut);
end;
procedure TEmbeddedWB.PageSetup(UsePrintOptions: Boolean);
var
vaIn, vaOut: Olevariant;
begin
if UsePrintOptions then InvokingPageSetup := True;
InvokeCmd(FALSE, OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.OpenDialog;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_OPEN, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.SaveDialog;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.ViewSource;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(TRUE, HTMLID_VIEWSOURCE, 0, vaIn, vaOut);
end;
procedure TEmbeddedWB.Options;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(TRUE, HTMLID_OPTIONS, 0, vaIn, vaOut);
end;
procedure TEmbeddedWB.Properties;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.Find;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(TRUE, HTMLID_FIND, 0, vaIn, vaOut);
end;
procedure TEmbeddedWB.Copy;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.SelectAll;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.Zoom(ZoomValue: Integer);
var
vaIn, vaOut: Olevariant;
begin
if ZoomValue < ZoomRangeLow then vaIn := ZoomRangeLow else
if ZoomValue > ZoomRangeHigh then vaIn := ZoomRangeHigh else
vaIn := ZoomValue;
InvokeCmd(FALSE, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;
function TEmbeddedWB.ZoomRangeLow: Integer;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
result := LoWord(Dword(vaOut));
end;
function TEmbeddedWB.ZoomRangeHigh: Integer;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
result := HiWord(Dword(vaOut));
end;
function TEmbeddedWB.ZoomValue: Integer;
var
vaIn, vaOut: Olevariant;
begin
vaIn := null;
InvokeCmd(FALSE, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
result := vaOut;
end;
// IDOCHOSTUIHANDLER
function TEmbeddedWB.ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT;
begin
if Assigned(FOnShowContextmenu) then RESULT := FOnSHowContextmenu(dwID, ppt,
pcmdtreserved, pdispreserved) else
RESULT := S_FALSE;
end;
function TEmbeddedWB.GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT;
begin
pInfo.cbSize := SizeOf(pInfo);
pInfo.dwFlags := FUserInterfaceValue;
pInfo.dwDoubleClick := DOCHOSTUIDBLCLK_DEFAULT;
if Assigned(FOnGetHostInfo) then
Result := FOnGetHostInfo(pInfo) else
Result := S_OK;
end;
function TEmbeddedWB.ShowUI(const dwID: DWORD;
const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HRESULT;
begin
if Assigned(FOnShowUI) then
Result := FOnShowUI(dwID, pActiveObject, pCommandTarget, pFrame, pDoc)
else
Result := S_FALSE;
end;
function TEmbeddedWB.HideUI: HRESULT;
begin
if Assigned(FOnHideUI) then
Result := FOnHideUI else
Result := S_FALSE;
end;
function TEmbeddedWB.UpdateUI: HRESULT;
begin
if Assigned(FOnUpdateUI) then
Result := FOnUpdateUI else
Result := S_FALSE;
end;
function TEmbeddedWB.EnableModeless(const fEnable: BOOL): HRESULT;
begin
if Assigned(FOnEnableModeless) then
Result := FOnEnableModeless(fEnable) else
Result := S_FALSE;
end;
function TEmbeddedWB.OnDocWindowActivate(const fActivate: BOOL): HRESULT;
begin
if Assigned(FOnOnDocWindowActivate) then
Result := FOnOnDocWindowActivate(fActivate) else
Result := S_FALSE;
end;
function TEmbeddedWB.OnFrameWindowActivate(const fActivate: BOOL): HRESULT;
begin
if Assigned(FOnOnFrameWindowActivate) then
Result := FOnOnFrameWindowActivate(fActivate) else
Result := S_FALSE;
end;
function TEmbeddedWB.ResizeBorder(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT;
begin
if Assigned(FOnResizeBorder) then
Result := FOnResizeBorder(prcBorder, pUIWindow, fRameWindow) else
Result := S_FALSE;
end;
function TEmbeddedWB.TranslateAccelerator(const lpMsg: PMSG;
const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT;
begin
if Assigned(FOnTranslateAccelerator) then
Result := FOnTranslateAccelerator(lpMsg, pguidCmdGroup, nCmdID) else
Result := S_FALSE;
end;
function TEmbeddedWB.GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT;
begin
if Assigned(FOnGetOptionKeyPath) then
Result := FOnGetOptionKeyPath(pchKey, dw) else
Result := S_FALSE;
end;
function TEmbeddedWB.GetDropTarget(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HRESULT;
begin
if Assigned(FOnGetDropTarget) then
Result := FOnGetDropTarget(pDropTarget, ppDropTarget) else
Result := S_OK;
end;
function TEmbeddedWB.GetExternal(out ppDispatch: IDispatch): HRESULT;
begin
if Assigned(FOnGetExternal) then
Result := FOnGetExternal(ppDispatch) else
Result := S_FALSE;
end;
function TEmbeddedWB.TranslateUrl(const dwTranslate: DWORD;
const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT;
begin
if Assigned(FOnTranslateUrl) then
Result := FOnTranslateUrl(dwTranslate, pchUrlIn, ppchUrlOut) else
Result := S_FALSE;
end;
function TEmbeddedWB.FilterDataObject(const pDO: IDataObject;
out ppDORet: IDataObject): HRESULT;
begin
if Assigned(FOnFilterDataObject) then
Result := FOnFilterDataObject(pDO, ppDORet) else
Result := S_FALSE;
end;
// IDOCHOSTSHOWUI
function TEmbeddedWB.ShowMessage(hwnd: THandle; lpstrText: POLESTR;
lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR;
dwHelpContext: longint; var plResult: LRESULT): HRESULT;
begin
if Assigned(FOnShowMessage) then
Result := FOnShowMessage(hwnd, lpstrText, lpStrCaption, dwType, lpStrHelpFile, dwHelpContext, plResult) else
Result := S_FALSE;
end;
function TEmbeddedWB.ShowHelp(hwnd: THandle; pszHelpFile: POLESTR;
uCommand: integer; dwData: longint; ptMouse: TPoint;
var pDispatchObjectHit: IDispatch): HRESULT;
begin
Result := S_OK;
if Assigned(FOnShowHelp) then
Result := FOnShowHelp(hwnd, pszHelpFile, uCommand, dwData, ptMouse, pDispatchObjectHit) else
if FHelpFile <> '' then HtmlHelp(hwnd, Pchar(FHelpFile), ucommand, dwData) else
Result := S_FALSE;
end;
// IDISPATCH methods
function TEmbeddedWB.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
if Assigned(FOnGetIdsofNames) then
Result := FOnGetIdsofNames(IID, Names, NameCount, LocaleID, DispIds) else
result := E_NotImpl;
end;
function TEmbeddedWB.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
if Assigned(FOnGetTypeInfo) then
Result := FOnGetTypeInfo(Index, LocaleID, ITypeInfo(TypeInfo)) else
begin
Result := E_NOTIMPL;
pointer(TypeInfo) := nil;
end;
end;
function TEmbeddedWB.GetTypeInfoCount(out Count: Integer): HResult;
begin
if Assigned(FOnGetTypeInfoCount) then
Result := FOnGetTypeInfoCount(Count) else
begin
Result := E_NOTIMPL;
Count := 0;
end;
end;
function TEmbeddedWB.Invoke(DispID: Integer;
const IID: TGUID;
LocaleID: Integer;
Flags: Word;
var Params;
VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
begin
Result := S_OK;
if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) and
(DispId = DISPID_AMBIENT_DLCONTROL) then
PVariant(VarResult)^ := FDownloadOptionValue
else
if Assigned(FOnInvoke) then
Result := FOnInvoke(DispId, IID, LocaleID, Flags, TagDispParams(Params),
VarResult, ExcepInfo, ArgErr)
else
Result := inherited Invoke(DispID, IID, LocaleID, Flags, Params,
VarResult, ExcepInfo, ArgErr);
end;
procedure Register;
begin
RegisterComponents({$IFDEF VER120} 'ActiveX'{$ELSE} 'Internet'{$ENDIF}, [TEmbeddedWB]);
end;
{ TPrintOptions }
procedure TPrintOptions.SetHTMLHeader(const Value: Tstrings);
begin
FHTMLHeader.Assign(Value);
end;
function DeleteFirstCacheEntry(var H: THandle): DWORD;
var
T: PInternetCacheEntryInfo;
D: DWord;
begin
Result := S_OK;
H := 0;
D := 0;
FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, nil, @D, nil, nil, nil);
GetMem(T, D);
try
H := FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, T, @D, nil, nil, nil);
if (H = 0) then Result := GetLastError else DeleteUrlCacheEntry(T^.lpszSourceUrlname);
finally
FreeMem(T, D)
end;
end;
function DeleteNextCacheEntry(H: THandle): DWORD;
var
T: PInternetCacheEntryInfo;
D: DWORD;
begin
Result := S_OK;
D := 0;
FindnextUrlCacheEntryEx(H, nil, @D, nil, nil, nil);
GetMem(T, D);
try
if not FindNextUrlCacheEntryEx(H, T, @D, nil, nil, nil)
then Result := GetLastError else DeleteUrlCacheEntry(T^.lpszSourceUrlname);
finally
FreeMem(T, D)
end;
end;
procedure TEmbeddedWB.ClearCache;
var
H: THandle;
begin
if DeleteFirstCacheEntry(H) = S_OK then
repeat
until DeleteNextCacheEntry(H) = ERROR_NO_MORE_ITEMS;
FindCloseUrlCache(H)
end;
procedure TEmbeddedWB.ClearHistory;
var
HistoryStg: IUrlHistoryStg2;
begin
HistoryStg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2;
HistoryStg.ClearHistory;
end;
function TEmbeddedWB.GetOverrideKeyPath(pchKey: POLESTR;
dw: DWORD): HRESULT;
begin
if Assigned(FOnGetOverrideKeyPath) then RESULT := FOnGetOverrideKeyPath(pchkey, dw) else
Result := S_OK;
end;
{$IFDEF USE_IOLECOMMANDTARGET}
function TEmbeddedWB.Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
const vaIn: OleVariant; var vaOut: OleVariant): HResult;
var
FCancel, FContinueScript, FShowDialog: Boolean;
pEventObj: IHTMLEventObj;
function GetProperty(const PropName: WideString): OLEVariant;
var
Dispparams: TDispParams;
Disp, Status: Integer;
ExcepInfo: TExcepInfo;
PPropName: PWideChar;
begin
Dispparams.rgvarg := nil;
Dispparams.rgdispidNamedArgs := nil;
Dispparams.cArgs := 0;
Dispparams.cNamedArgs := 0;
PPropName := PWideChar(PropName);
Status := pEventObj.GetIDsOfNames(GUID_NULL, @PPropname, 1,
LOCALE_SYSTEM_DEFAULT, @Disp);
if Status = 0 then
begin
Status := pEventObj.Invoke(disp, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET,
Dispparams, @Result, @ExcepInfo, nil);
if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
end else
if Status = DISP_E_UNKNOWNNAME then
raise EOleError.CreateFmt('''%s'' not supported.', [PropName])
else
OleCheck(Status);
end;
begin
if (CmdGroup = nil) then
begin
Result := OLECMDERR_E_UNKNOWNGROUP;
exit;
end;
Result := OLECMDERR_E_NOTSUPPORTED;
if (ncmdID = OLECMDID_ONUNLOAD) and IsEqualGuid(cmdGroup^, CGID_EXPLORER) and
Assigned(FOnUnload) then FOnUnload(Self);
if IsEqualGuid(cmdGroup^, CGID_DocHostCommandHandler) then
begin
if Assigned(FOnRefresh) and ((nCmdID = 6041 {F5}) or (nCmdID = 6042 {ContextMenu}) or (nCmdID = 2300)) then
begin
FCancel := False;
FOnRefresh(self, nCmdID, FCancel);
if FCancel then Result := S_OK;
end else
case nCmdID of
OLECMDID_SHOWSCRIPTERROR:
if Assigned(FOnScriptError)
then begin
pEventObj := (Document as IHTMLDocument2).parentWindow.event;
if pEventObj <> nil then
begin
FContinueScript := True;
FShowDialog := True;
FOnScriptError(self,
GetProperty('errorline'),
GetProperty('errorCharacter'),
GetProperty('errorCode'),
GetProperty('errorMessage'),
GetProperty('errorUrl'),
FContinueScript, FShowDialog);
TVariantArg(vaOut).vt := VT_BOOL;
TVariantArg(vaOut).vbool := FContinueScript;
if not FShowDialog then Result := S_OK;
end;
end;
end;
end;
end;
function TEmbeddedWB.QueryStatus(CmdGroup: PGUID; cCmds: Cardinal;
prgCmds: POleCmd; CmdText: POleCmdText): HResult;
begin
result := S_OK;
end;
{$ENDIF}
initialization
Saved8087CW := Default8087CW;
{$IFDEF VER120}
bMsgHandler := False;
{$ENDIF}
OleInitialize(nil);
finalization
Set8087CW(Saved8087CW);
try
OleUninitialize;
except end;
end.
//***********************************************************
// EmbeddedWb ver 1.16b (Oct. 15 , 2001) *
// *
// For Delphi 4, 5 and 6 *
// Freeware Component *
// by *
// Per Linds?Larsen *
// per.lindsoe@larsen.mail.dk *
// *
// *
// Contributors: *
// *
// Mathias Walter (walter@coint.de) *
// - all messagehandling code *
// *
// Neil Moss (NeilM@BuchananInternational.com) *
// - code for setting downloadoptions *
// *
// Documentation and updated versions: *
// *
// http://www.euromind.com/iedelphi *
//***********************************************************
unit EmbeddedWB;
interface
uses
{$IFDEF VER140}Variants, {$ENDIF}
IEConst, IEUtils, Registry, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
EXTCtrls, OleCtrls, Mshtml, SHDocVw, ActiveX, shlObj, Wininet, Urlmon, shellapi;
type
{$IFDEF USE_IOLECOMMANDTARGET}
TScriptErrorEvent = procedure(Sender: TObject; ErrorLine, ErrorCharacter, ErrorCode, ErrorMessage, ErrorUrl: string;
var ContinueScript: Boolean; var Showdialog: Boolean) of object;
TRefreshEvent = procedure(Sender: TObject; CmdID: Integer; var Cancel: Boolean) of object;
TUnloadEvent = procedure(Sender: TObject) of object;
{$ENDIF}
TGetOverrideKeyPathEvent = function(pchKey: POLESTR; dw: DWORD): HRESULT of object;
TShowContextMenuEvent = function(const dwID: DWORD; const ppt: PPOINT;
const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT of object;
TGetHostInfoEvent = function(var pInfo: TDOCHOSTUIINFO): HRESULT of object;
TShowUIEvent = function(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HRESULT of object;
THideUIEvent = function: HRESULT of object;
TUpdateUIEvent = function: HRESULT of object;
TEnableModelessEvent = function(const fEnable: BOOL): HRESULT of object;
TOnDocWindowActivateEvent = function(const fActivate: BOOL): HRESULT of object;
TOnFrameWindowActivateEvent = function(const fActivate: BOOL): HRESULT of object;
TResizeBorderEvent = function(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow;
const fRameWindow: BOOL): HRESULT of object;
TTranslateAcceleratorEvent = function(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
const nCmdID: DWORD): HRESULT of object;
TGetOptionKeyPathEvent = function(var pchKey: POLESTR; const dw: DWORD): HRESULT of object;
TGetDropTargetEvent = function(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HRESULT of object;
TGetExternalEvent = function(out ppDispatch: IDispatch): HRESULT of object;
TTranslateUrlEvent = function(const dwTranslate: DWORD; const pchURLIn: POLESTR;
var ppchURLOut: POLESTR): HRESULT of object;
TFilterDataObjectEvent = function(const pDO: IDataObject;
out ppDORet: IDataObject): HRESULT of object;
TShowMessageEvent = function(hwnd: THandle;
lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR;
dwHelpContext: longint; var plResult: LRESULT): HRESULT of object;
TShowHelpEvent = function(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer;
dwData: longint; ptMouse: TPoint;
var pDispatchObjectHit: IDispatch): HRESULT of object;
TGetTypeInFoCountEvent = function(out Count: Integer): HResult of object;
TGetTypeInfoEvent = function(Index, LocaleID: Integer; out TypeInfo: ITypeInfo): HResult of object;
TGetIDsOfNamesEvent = function(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult of object;
TInvokeEvent = function(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params: TagDispParams; VarResult, ExcepInfo, ArgErr: Pointer): HResult of object;
TQueryServiceEvent = function(const rsid, iid: TGuid; out Obj: IUnknown): HResult of object;
TShowDialogEvent = procedure(Sender: TObject; h: THandle) of object;
TDownloadControlOption = (DLCTL_DLIMAGES, DLCTL_VIDEOS, DLCTL_BGSOUNDS,
DLCTL_NO_SCRIPTS, DLCTL_NO_JAVA, DLCTL_NO_RUNACTIVEXCTLS, DLCTL_NO_DLACTIVEXCTLS,
DLCTL_DOWNLOADONLY, DLCTL_NO_FRAMEDOWNLOAD, DLCTL_RESYNCHRONIZE, DLCTL_PRAGMA_NO_CACHE,
DLCTL_NO_BEHAVIORS, DLCTL_NO_METACHARSET, DLCTL_URL_ENCODING_DISABLE_UTF8,
DLCTL_URL_ENCODING_ENABLE_UTF8, DLCTL_FORCEOFFLINE, DLCTL_NO_CLIENTPULL,
DLCTL_SILENT, DLCTL_OFFLINE);
TDownloadControlOptions = set of TDownloadControlOption;
TUserInterfaceOption = (DIALOG, DISABLE_HELP_MENU, NO3DBORDER,
SCROLL_NO, DISABLE_SCRIPT_INACTIVE, OPENNEWWIN, DISABLE_OFFSCREEN,
FLAT_SCROLLBAR, DIV_BLOCKDEFAULT, ACTIVATE_CLIENTHIT_ONLY, OVERRIDEBEHAVIORFACTORY,
CODEPAGELINKEDFONTS, URL_ENCODING_DISABLE_UTF8, URL_ENCODING_ENABLE_UTF8,
ENABLE_FORMS_AUTOCOMPLETE, ENABLE_INPLACE_NAVIGATION, IME_ENABLE_RECONVERSION);
TUserInterfaceOptions = set of TUserInterfaceOption;
type
TMeasure = (mMetric, mUS);
TPrintOrientationOption = (poPortrait, poLandscape);
TMargins = class(TPersistent)
private
FLeft: Real;
FRight: Real;
FTop: Real;
FBottom: real;
published
property Left: Real read FLeft write FLeft;
property Right: Real read FRight write FRight;
property Top: Real read FTop write FTop;
property Bottom: Real read FBottom write FBottom;
end;
TPrintOptions = class(TPersistent)
private
FHTMLHeader: TStrings;
FHeader: string;
FFooter: string;
FMargins: TMargins;
FOrientation: TPrintOrientationOption;
FMeasure: TMeasure;
procedure SetHTMLHeader(const Value: Tstrings);
property Measure: TMeasure read FMeasure;
published
property Margins: TMargins read FMargins write FMargins;
property Header: string read FHeader write FHeader;
property HTMLHeader: TStrings read FHTMLHeader write SetHTMLHeader;
property Footer: string read FFooter write FFooter;
property Orientation: TPrintOrientationOption read FOrientation write FOrientation;
end;
TEmbeddedWB = class(TWebbrowser, IDocHostShowUI, IDocHostUIHandler,
IDocHostUIHandler2, IDispatch, IServiceProvider
{$IFDEF USE_IOLECOMMANDTARGET}, IOleCommandTarget{$ENDIF})
private
{$IFDEF VER120}
SaveMessage: TMessageEvent;
{$ENDIF}
FUserAgent: string;
FReplaceCaption: Boolean;
FPrintOptions: TPrintOPtions;
FDownloadControlOptions: TDownloadControlOptions;
FUserInterfaceOptions: TUserInterfaceOptions;
{$IFDEF USE_IOLECOMMANDTARGET}
FOnUnload: TUnloadEvent;
FOnRefresh: TRefreshEvent;
FOnScriptError: TScriptErrorEvent;
{$ENDIF}
FOnGetOverrideKeyPath: TGetOverrideKeypathEvent;
FOnShowContextMenu: TShowcontextmenuEvent;
FOnGetHostInfo: TGetHostInfoEvent;
FOnShowUI: TShowUIEvent;
FOnHideUI: THideUIEvent;
FOnUpdateUI: TUpdateUIEvent;
FOnEnableModeless: TEnableModelessEvent;
FOnOnDocWindowActivate: TOnDocWindowActivateEvent;
FOnOnFrameWindowActivate: TOnFrameWindowActivateEvent;
FOnResizeBorder: TResizeBorderEvent;
FOnTranslateAccelerator: TTranslateAcceleratorEvent;
FOnGetOptionKeyPath: TGetOptionKeyPathEvent;
FOnGetDropTarget: TGetDropTargetEvent;
FOnGetExternal: TGetExternalEvent;
FOnTranslateUrL: TTranslateUrlEvent;
FOnFilterDataObject: TFilterDataObjectEvent;
FHelpFile: string;
FOnShowMessage: TShowMessageEvent;
FOnShowHelp: TShowHelpEvent;
FOnGetTypeInfoCount: TGetTypeInfoCountEvent;
FOnGetTypeInfo: TGetTypeInfoEvent;
FOnGetIDsOfNames: TGetIDsOfNamesEvent;
FOnInvoke: TInvokeEvent;
FOnQueryService: TQueryServiceEvent;
FOldWindowProc: TWndMethod;
FParentForm: TForm;
FDownloadOptionValue: Longint;
FUserInterfaceValue: Cardinal;
FOnCloseQuery: TCloseQueryEvent;
FOnShowDialog: TShowDialogEvent;
OldWBWndProc: TWndMethod;
RuntimeMeasure: TMeasure;
DDEHWnd: THandle;
FEnableDDE: Boolean;
FfpExceptions: Boolean;
procedure SetUserAgent;
procedure RemoveUserAgent;
procedure GetPrintValues;
procedure Hook;
procedure UnHook;
procedure FormWndProc(var AMsg: TMessage);
procedure DDEWndProc(var AMsg: TMessage);
procedure WBWndProc(var Message: TMessage);
procedure SetDownloadOptions(const Value: TDownloadControlOptions);
procedure SetUserInterfaceOptions(const Value: TUserInterfaceOptions);
procedure SetfpExceptions(const Value: Boolean);
procedure UpdateDownloadControlValue;
procedure UpdateUserInterfaceValue;
protected
function DDETerminate(iwParam: WPARAM; ilParam: LPARAM): BOOL;
function DDEInitiate(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
function DDEExecute(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
function GetOverrideKeyPath(pchKey: POLESTR; dw: DWORD): HRESULT; stdcall;
{$IFDEF USE_IOLECOMMANDTARGET}
function QueryStatus(CmdGroup: PGUID; cCmds: Cardinal;
prgCmds: POleCmd; CmdText: POleCmdText): HResult; stdcall;
function Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
const vaIn: OleVariant; var vaOut: OleVariant): HResult; stdcall;
{$ENDIF}
function ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT; stdcall;
function GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT; stdcall;
function ShowUI(const dwID: DWORD; const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HRESULT; stdcall;
function HideUI: HRESULT; stdcall;
function UpdateUI: HRESULT; stdcall;
function EnableModeless(const fEnable: BOOL): HRESULT; stdcall;
function OnDocWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
function OnFrameWindowActivate(const fActivate: BOOL): HRESULT; stdcall;
function ResizeBorder(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow;
const FrameWindow: BOOL): HRESULT; stdcall;
function TranslateAccelerator(const lpMsg: PMSG; const pguidCmdGroup: PGUID;
const nCmdID: DWORD): HRESULT; stdcall;
function GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT; stdcall;
function GetDropTarget(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HRESULT; stdcall;
function GetExternal(out ppDispatch: IDispatch): HRESULT; stdcall;
function TranslateUrl(const dwTranslate: DWORD; const pchURLIn: POLESTR;
var ppchURLOut: POLESTR): HRESULT; stdcall;
function FilterDataObject(const pDO: IDataObject;
out ppDORet: IDataObject): HRESULT; stdcall;
function ShowMessage(hwnd: THandle;
lpstrText: POLESTR; lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR;
dwHelpContext: longint; var plResult: LRESULT): HRESULT; stdcall;
function ShowHelp(hwnd: THandle; pszHelpFile: POLESTR; uCommand: integer;
dwData: longint; ptMouse: TPoint;
var pDispatchObjectHit: IDispatch): HRESULT; stdcall;
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
{$IFDEF VER120}
procedure IEMessageHandler(var Msg: TMsg; var Handled: Boolean);
{$ENDIF}
function QueryService(const rsid, iid: TGuid; out Obj): HResult; stdcall;
function OpenClient(Client: string): Boolean;
function PrintMarginStr(M: Real): PChar;
public
SecurityManager: IInternetSecurityManager;
ZoneManager: IInternetZoneManager;
function ShowMailClient: Boolean;
function ShowNewsClient: Boolean;
function ShowAddressBook: Boolean;
function ShowCalendar: Boolean;
function ShowInternetCall: Boolean;
procedure AssignDocument;
procedure SetFocusToDoc;
procedure InvokeCMD(InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant);
procedure Go(Url: string);
procedure Print;
procedure OpenDialog;
procedure SaveDialog;
procedure PrintSetup;
procedure PageSetup(UsePrintOptions: Boolean);
procedure ViewSource;
procedure Properties;
procedure Options;
procedure Find;
{$IFDEF VER120}
procedure EnableMessagehandler;
procedure DisableMessagehandler;
{$ENDIF}
procedure Copy;
procedure SelectAll;
procedure Zoom(ZoomValue: Integer);
function ZoomRangeHigh: Integer;
function ZoomRangeLow: Integer;
function ZoomValue: Integer;
procedure NavigatePidl(pidl: PItemIdlist);
procedure NavigateFolder(CSIDL: Integer);
procedure SetGlobalOffline(Value: Boolean);
function IsGlobalOffline: boolean;
function LoadFrameFromStrings(Frameno: Integer; const AStrings: TStrings): HResult;
function LoadFrameFromStream(FrameNo: Integer; AStream: TStream): HRESULT;
function SaveFrameToFile(FrameNo: Integer; const Fname: string): HRESULT;
function SaveFrameToStream(FrameNo: Integer; AStream: TStream): HRESULT;
function SaveFrameToStrings(FrameNo: Integer; AStrings: TStrings): HRESULT;
function LoadFromStream(const AStream: TStream): HRESULT;
function LoadFromStrings(const AStrings: TStrings): HRESULT;
function SaveToStrings(AStrings: TStrings): HRESULT;
function SaveToStream(AStream: TStream): HRESULT;
function SaveToFile(const Fname: string): HRESULT;
constructor Create(Owner: TComponent); override;
procedure Loaded; override;
destructor Destroy; override;
procedure PrintPreView;
procedure PrintWithOptions;
function GetFrame(FrameNo: Integer): IWebbrowser2;
function FrameCount: LongInt;
procedure GetThumbnail(var Image: TImage);
procedure ClearHistory;
procedure ClearCache;
published
property DownloadOptions: TDownloadControlOptions read FDownloadControlOptions write SetDownloadOptions;
property UserInterfaceOptions: TUserInterfaceOptions read FUserInterfaceOptions write SetUserInterfaceOptions;
{$IFDEF USE_IOLECOMMANDTARGET}
property OnRefresh: TRefreshEvent read FOnRefresh write FOnRefresh;
property OnScriptError: TScriptErrorEvent read FOnScriptError write FOnScriptError;
property OnUnload: TUnloadEvent read FOnUnload write FOnUnload;
{$ENDIF}
property OnGetOverrideKeyPath: TGetOVerrideKeypathEvent read FOnGetOverrideKeyPath write FOnGetOverrideKeyPath;
property OnShowContextMenu: TShowContextMenuEvent read FOnShowContextmenu write FOnShowContextmenu;
property OnGetHostInfo: TGetHostInfoEvent read FOnGethostinfo write fongethostinfo;
property OnShowUI: TShowUIEvent read FOnShowUI write FOnShowUI;
property OnHideUI: THideUIEvent read FOnHideUI write FOnHideUI;
property OnUpdateUI: TUpdateUIEvent read FOnUpdateUI write FOnUpdateUI;
property OnEnableModeless: TEnableModelessEvent read FOnEnableModeless write FOnEnableModeless;
property OnOnDocWindowActivate: TOnDocWindowActivateEvent read FOnOnDocWindowActivate write FOnOnDocWindowActivate;
property OnOnFrameWindowActivate: TOnFrameWindowActivateEvent read FOnOnFrameWindowActivate write FOnOnFrameWindowActivate;
property OnResizeBorder: TResizeBorderEvent read FOnResizeBorder write FOnResizeBorder;
property OnTranslateAccelerator: TTranslateAcceleratorEvent read FOnTranslateAccelerator write FOnTranslateAccelerator;
property OnGetOptionKeyPath: TGetOptionKeyPathEvent read FOnGetOptionKeyPath write FOnGetOptionKeyPath;
property OnGetDropTarget: TGetDropTargetEvent read FOnGetDropTarget write FOnGetDropTarget;
property OnGetExternal: TGetExternalEvent read FOnGetExternal write FOnGetExternal;
property OnTranslateUrl: TTranslateUrlEvent read FOnTranslateUrL write FOnTranslateUrL;
property OnFilterDataObject: TFilterDataObjectEvent read FOnFilterDataObject write FOnFilterDataObject;
property HelpFile: string read FHelpFile write FHelpFile;
property OnShowMessage: TShowMessageEvent read FOnShowMessage write FOnShowMessage;
property OnShowHelp: TShowHelpEvent read FOnShowHelp write FOnShowHelp;
property OnGetTypeInfoCount: TGetTypeInfoCountEvent read FonGetTypeInfoCount write FOnGetTypeInfoCount;
property OnGetTypeInfo: TGetTypeInfoEvent read FonGetTypeInfo write FOnGetTypeInfo;
property OnGetIDsOfNames: TGetIDsOfNamesEvent read FOnGetIDsOfNames write FOnGetIdsOfNames;
property OnInvoke: TInvokeEvent read FOnInvoke write FOnInvoke;
property OnQueryService: TQueryServiceEvent read FOnQueryService write FOnQueryService;
property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery;
property OnShowDialog: TShowDialogEvent read FOnShowDialog write FOnShowDialog;
property PrintOptions: TPrintOptions read FPrintOptions write FPrintOptions;
property UserAgent: string read FUserAgent write FUserAgent;
property ReplaceCaption: Boolean read FReplaceCaption write FReplaceCaption;
property EnableDDE: Boolean read FEnableDDE write FEnableDDE;
property fpExceptions: Boolean read FfpExceptions write SetfpExceptions;
end;
function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
function RegisterNameSpace(clsid: TGUID): HRESULT;
function UnregisterNameSpace: HRESULT;
procedure Register;
implementation
uses comobj;
var
Saved8087CW: Word;
PrintingWithOptions: Boolean;
InvokingPagesetup: Boolean;
MimeFactory, NSFactory: IClassFactory;
MimeInternetSession, NSInternetSession: IInternetSession;
DontRespond: Boolean;
OpenFolder, ExploreFolder: string;
FoldersApp, FoldersTopic: string;
FindFolder: string;
HtmlFileApp, HtmlFileTopic: string;
fHtmlCommand: Boolean;
{$IFDEF VER120}
bMsgHandler: Boolean;
{$ENDIF}
procedure TEmbeddedWB.GetThumbnail(var Image: TImage);
var
DrawRect: TRect;
begin
if Image = nil then exit;
DrawRect := Rect(0, 0, Image.Height, Image.width);
Image.Picture.Bitmap.Height := image.height;
Image.Picture.Bitmap.Width := image.Width;
({$IFDEF VER120}Application_{$ELSE}Application{$ENDIF} as IviewObject).Draw(DVASPECT_DOCPRINT, 0, nil, nil, 0,
image.Canvas.Handle, @DrawRect, nil, nil, 0);
Image.Refresh;
end;
procedure TEmbeddedWB.SetfpExceptions(const Value: Boolean);
begin
if not Value then begin
Set8087CW($133F);
FfpExceptions := False;
end
else
begin
Set8087CW(Saved8087CW);
FfpExceptions := True;
end;
end;
function TEmbeddedwb.GetFrame(FrameNo: Integer): IWebbrowser2;
var
OleContainer: IOleContainer;
enum: IEnumUnknown;
unk: IUnknown;
Fetched: PLongint;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(document) then
begin
Fetched := nil;
OleContainer := Document as IOleContainer;
OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
Enum.Skip(FrameNo);
Enum.Next(1, Unk, Fetched);
Result := Unk as IWebbrowser2;
end else Result := nil;
end;
{
Ver. 1.16:
Thanks to Brian Lowe for Fixing OLE-problem in function FrameCount:
http://groups.yahoo.com/group/delphi-webbrowser/message/4194
}
function TEmbeddedWB.FrameCount: LongInt;
var
OleContainer: IOleContainer;
enum: IEnumUnknown;
unk: array[0..99] of IUnknown; // CHANGED from "unk: IUnknown;"
EnumResult: HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(document) then
begin
OleContainer := Document as IOleContainer;
EnumResult := OleContainer.EnumObjects(OLECONTF_EMBEDDINGS, Enum);
if EnumResult = S_OK then // Added per OLE help
Enum.Next(100, Unk, @Result)
else // Added per OLE help
Enum := nil;
end else
Result := 0;
end;
procedure TEmbeddedWB.SetUserAgent;
var
reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('/Software/Microsoft/Windows/CurrentVersion/Internet Settings/User Agent/Post Platform', True)
then Reg.WriteString(FUserAgent, '');
finally
Reg.CloseKey;
Reg.Free;
end;
end;
procedure TEmbeddedWB.RemoveUserAgent;
var
reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
if Reg.OpenKey('/Software/Microsoft/Windows/CurrentVersion/Internet Settings/User Agent/Post Platform', FALSE)
then reg.DeleteValue(FUseragent);
finally
Reg.CloseKey;
Reg.Free;
end;
end;
function GetDDEVariables: Boolean;
var
s: string;
Reg: TRegistry;
begin
Reg := Tregistry.Create;
with Reg do try
RootKey := HKEY_CLASSES_ROOT;
OpenKey('htmlfile/shell/open/ddeexec/application', False);
HtmlFileApp := Readstring('');
CloseKey;
OpenKey('htmlfile/shell/open/ddeexec/topic', FALSE);
HtmlFileTopic := ReadString('');
CloseKey;
OpenKey('Folder/shell/open/ddeexec/application', False);
FoldersApp := Readstring('');
CloseKey;
OpenKey('Folder/shell/open/ddeexec/topic', FALSE);
FoldersTopic := ReadString('');
CloseKey;
OpenKey('Folder/shell/open/ddeexec', False);
s := readString('');
CloseKey;
S := Copy(S, Pos('[', S) + 1, length(S));
OpenFolder := Copy(s, 1, Pos('(', S) - 1);
OpenKey('Folder/shell/explore/ddeexec', False);
s := readString('');
CloseKey;
S := Copy(S, Pos('[', S) + 1, length(S));
ExploreFolder := Copy(s, 1, Pos('(', S) - 1);
OpenKey('Directory/shell/find/ddeexec', False);
s := readString('');
CloseKey;
S := Copy(S, Pos('[', S) + 1, length(S));
FindFolder := Copy(s, 1, Pos('(', S) - 1);
Result := True;
except
Result := False;
end;
Reg.Free;
end;
function GetCommandTypeFromDDEString(szCommand: string): UINT;
begin
szCommand := Copy(szCommand, Pos('[', szCommand) + 1, length(szCommand));
szCommand := Copy(szCommand, 1, Pos('(', szCommand) - 1);
if szCommand = Openfolder then Result := VIEW_COMMAND else
if szCommand = Explorefolder then Result := EXPLORE_COMMAND else
if szCommand = Findfolder then Result := FIND_COMMAND else
Result := NO_COMMAND;
end;
function GetPathFromDDEString(szCommand: string; var szFolder: string): Boolean;
begin
szCommand := Copy(szCommand, Pos('"', szCommand) + 1, length(szCommand));
szFolder := Copy(szCommand, 1, Pos('"', szCommand) - 1);
Result := (szFolder <> '');
end;
function GetPidlFromDDEString(szCommand: string): PItemIDList;
var
pidlShared, pidlGlobal: PItemIDList;
dwProcessID: Integer;
hShared: THandle;
s: string;
ProcessID: string;
i: Integer;
begin
s := Copy(szCommand, Pos(',', szCommand) + 1, length(szCommand));
i := 1;
while not (s in IsDigit) and (i <= Length(s)) do Inc(i);
processID := Copy(s, i, Length(S));
s := copy(S, i, length(s) - 1);
i := 1;
while (s in IsDigit) and (i <= Length(s)) do Inc(i);
s := copy(S, 1, i - 1);
while not ((ProcessID = ':') or (ProcessID = ',')) and (i <= Length(processID)) do Inc(i);
if ProcessID = ':' then
begin
ProcessID := Copy(ProcessID, i, Length(ProcessID));
i := 1;
while not (ProcessID in IsDigit) and (i <= Length(ProcessID)) do Inc(i);
ProcessID := Copy(ProcessID, i, Length(ProcessID));
i := 1;
while (ProcessID in IsDigit) and (i <= Length(ProcessID)) do Inc(i);
if not (ProcessID in IsDigit) then ProcessID := Copy(ProcessID, 1, i - 1);
end else ProcessID := '0';
dwProcessID := StrToInt(ProcessID);
if dwProcessID <> 0 then begin
hShared := StrToInt(s);
pidlShared := ShLockShared(hShared, dwProcessId);
if PidlShared <> nil then
begin
Result := CopyPidl(PidlShared);
ShUnlockShared(pidlShared);
end else Result := nil;
ShFreeShared(hShared, dwProcessID);
end else
begin
pidlGlobal := PItemIDList(StrToInt(s));
Result := CopyPidl(pidlGlobal);
_Free(pidlGlobal);
end;
end;
function GetShowCmdFromDDEString(szCommand: string): Integer;
var
i: Integer;
begin
i := 1;
while szCommand <> ',' do Inc(i);
Inc(i);
while szCommand <> ',' do Inc(i);
szCommand := Copy(szCommand, i, Length(szCommand));
i := 0;
repeat
inc(i)
until (i > Length(szCommand)) or (szCommand in IsDigit);
if i <= length(szCommand) then result := StrtoInt(szCommand) else
result := 1;
end;
function ParseDDECommand(szCommand: string; var szFolder: string; var pidl: PItemIDList; var show: Integer): UINT;
begin
Result := GetCommandTypeFromDDEString(szCommand);
if Result <> NO_COMMAND then begin
GetPathFromDDEString(szCommand, szFolder);
pidl := GetPidlFromDDEString(szCommand);
Show := GetShowCmdFromDDEString(szCommand);
end;
end;
function TEmbeddedwb.DDETerminate(iwParam: WPARAM; ilParam: LPARAM): BOOL;
begin
Result := PostMessage(THandle(iwParam), WM_DDE_TERMINATE, handle, 0);
end;
function TEmbeddedWB.DDEInitiate(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
var
dwThreadID: DWORD;
dwProcessID: DWORD;
hwndClient: Integer;
aInApp,
aInTopic,
aOutApp,
aOutTopic: ATOM;
szInAppName,
szInAppTopic: array[0..255] of Char;
begin
FillChar(szInAppName, SizeOf(szInAppName), 0);
FillChar(szInAppTopic, SizeOf(szInAppTopic), 0);
if DontRespond then
begin
result := 0;
exit;
end;
hwndClient := THandle(iwParam);
dwThreadID := GetWindowThreadProcessId(hwndClient, @dwProcessID);
if (GetCurrentProcessId() <> dwProcessID) or (GetCurrentThreadID() <> dwThreadID) then
begin
result := 0;
exit;
end;
aInApp := LOWORD(ilParam);
aInTopic := HIWORD(ilParam);
GlobalGetAtomName(aInApp, szInAppName, SizeOf(szInAppName));
GlobalGetAtomName(aInTopic, szInAppTopic, SizeOf(szInAppTopic));
if szInAppName = HtmlFileApp then
begin
fHtmlCommand := True;
aOutApp := GlobalAddAtom(PChar(HtmlFileApp));
aOutTopic := GlobalAddAtom(PChar(HtmlFileTopic));
if ((aOutApp <> 0) and (aOutTopic <> 0) and (aOutApp = aInApp) and (aOutTopic = aInTopic)) then
SendMessage(hwndClient, WM_DDE_ACK, WPARAM(handle), MAKELPARAM(aOutApp, aOutTopic));
if (aOutApp <> 0) then GlobalDeleteAtom(aOutApp);
if (aOutTopic <> 0) then GlobalDeleteAtom(aOutTopic);
end
else
begin
fHtmlCommand := False;
aOutApp := GlobalAddAtom(PChar(FoldersApp));
aOutTopic := GlobalAddAtom(PChar(FoldersTopic));
if ((aOutApp <> 0) and (aOutTopic <> 0) and (aOutApp = aInApp) and (aOutTopic = aInTopic)) then
SendMessage(HWNDClient, WM_DDE_ACK, WPARAM(Handle), MAKELPARAM(aOutApp, aOutTopic));
if (aOutApp <> 0) then GlobalDeleteAtom(aOutApp);
if (aOutTopic <> 0) then GlobalDeleteAtom(aOutTopic);
end;
result := 0;
end;
function TEmbeddedwb.DDEExecute(iwParam: WPARAM; ilParam: LPARAM): LRESULT;
var
szFolder: string;
szCommand: LPTSTR;
uLo: PUINT;
hgMem: HGLOBAL;
ack: DDEACK;
lpTemp: PUINT;
uCommand: Cardinal;
show: Integer;
pidl: PITEMIDLIST;
sei: TShellExecuteInfo;
szTmp: string;
begin
ulo := nil;
if UnpackDDElParam(WM_DDE_EXECUTE, ilParam, uLo, @hgMem)
then begin
szCommand := GlobalLock(hgmem);
ZeroMemory(@Ack, sizeof(ddeAck));
if (szCommand <> nil) then
begin
if fHtmlCommand then
begin
szTmp := szCommand;
if Pos('"', szTmp) = 1 then
begin
Delete(szTmp, 1, 1);
szTmp := System.Copy(szTmp, 1, Pos('"', szTmp) - 1);
end;
Go(szTmp);
Ack.flags := 1;
end
else
begin
uCommand := ParseDDECommand(szCommand, szFolder, pidl, Show);
case uCommand of
VIEW_COMMAND:
begin
if (szFolder <> '') then Go(szFolder)
else
if (pidl <> nil) then NavigatePidl(pidl);
DisposePidl(pidl);
Ack.flags := 1;
end;
EXPLORE_COMMAND:
begin
DontRespond := TRUE;
ZeroMemory(@sei, sizeof(SHELLEXECUTEINFO));
sei.cbSize := sizeof(SHELLEXECUTEINFO);
if szFolder <> '' then begin
sei.fMask := SEE_MASK_CLASSNAME;
sei.lpFile := Pchar(szFolder);
end else
begin
sei.fMask := SEE_MASK_IDLIST or SEE_MASK_CLASSNAME;
sei.lpIDList := pidl;
end;
sei.lpClass := 'folder';
sei.Wnd := 0;
sei.nShow := Show;
sei.lpVerb := 'explore';
ShellExecuteEx(@sei);
DontRespond := FALSE;
DisposePidl(pidl);
Ack.flags := 1;
end;
FIND_COMMAND:
begin
DontRespond := TRUE;
ZeroMemory(@sei, sizeof(SHELLEXECUTEINFO));
sei.cbSize := sizeof(SHELLEXECUTEINFO);
if (szFolder <> '')
then begin
sei.fMask := 0;
sei.lpFile := PChar(szFolder);
end
else
begin
sei.fMask := SEE_MASK_IDLIST;
sei.lpIDList := pidl;
end;
sei.wnd := 0;
sei.nShow := Show;
sei.lpVerb := 'find';
ShellExecuteEx(@sei);
DontRespond := FALSE;
DisposePidl(pidl);
Ack.flags := 1;
end;
end;
end;
GlobalUnlock(hgMem);
lpTemp := @Ack;
PostMessage(Thandle(iwParam),
WM_DDE_ACK,
WPARAM(handle),
ReuseDDElParam(ilParam, WM_DDE_EXECUTE, WM_DDE_ACK, lpTemp^, hgMem));
end;
end;
Result := 0;
end;
procedure TEmbeddedwb.PrintWithOptions;
begin
PrintingWithOptions := True;
Pagesetup(TRUE);
Print;
end;
procedure TembeddedWB.GetPrintValues;
var
S: string;
regWinRegistry: TRegistry;
function ReadMargin(key: string): Real;
begin
S := RegwinRegistry.ReadString(key);
S := Stringreplace(S, ' ', '', [rfReplaceAll]);
if DecimalSeparator <> '.' then
S := Stringreplace(S, '.', DecimalSeparator, []);
if Printoptions.Measure = mMetric then
result := StrtoFloat(S) * InchToMetric else
result := StrtoFloat(S);
end;
begin
regWinRegistry := TRegistry.Create;
try
with regWinRegistry do begin
RootKey := HKEY_CURRENT_USER;
if OpenKey('Software/Microsoft/Internet Explorer/PageSetup', False) then
begin
PrintOptions.Header := Readstring('header');
PrintOptions.Footer := ReadString('footer');
PrintOptions.Margins.left := ReadMargin('margin_left');
PrintOptions.Margins.right := ReadMargin('margin_right');
PrintOptions.Margins.top := ReadMargin('margin_top');
PrintOptions.Margins.bottom := ReadMargin('margin_bottom');
end;
end;
finally
regWinRegistry.Free;
end;
end;
procedure TEmbeddedWB.Loaded;
begin
inherited Loaded;
CoInternetCreateSecuritymanager(self, SecurityManager, 0);
CoInternetCreateZoneManager(self, ZoneManager, 0);
UpdateDownloadControlValue;
UpdateUserInterfaceValue;
hook;
if not (csDesigning in ComponentState) then
begin
OldWBWndProc := WindowProc;
WindowProc := WBWndProc;
SetUserAgent;
end else
begin
PrintOptions.FMeasure := RunTimeMeasure;
GetPrintValues;
end;
end;
function TEmbeddedWB.PrintMarginStr(M: Real): PChar;
var
S: string;
begin
if printOptions.Measure <> RuntimeMeasure
then begin
if RuntimeMeasure = mMetric then
s := FloatToStr(M * InchToMetric) else
s := FloatToStr(M / InchToMetric);
Result := PChar(S);
end else Result := PChar(FloatToStr(M));
end;
constructor TEmbeddedWb.Create(Owner: TComponent);
var
Buf: array[1..10] of Char;
begin
FfpExceptions := True;
inherited;
{$IFDEF VER120}
enablemessagehandler;
{$ENDIF}
GetDDEVariables;
DDEHWnd := AllocateHWnd(DDEWndProc);
FPrintOptions := TPrintOptions.Create;
FPrintOptions.Margins := TMargins.Create;
FPrintOptions.FHTMLHeader := TStringlist.Create;
FPrintOptions.FHTMLHeader.Add('<HTML></HTML>');
FillChar(Buf, SizeOf(Buf), 0);
GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IMEASURE, @Buf[1], SizeOf(Buf));
if Buf[1] = '1' then RunTimeMeasure := mUS else
RunTimeMeasure := mMetric;
DownloadOptions := [DLCTL_DLIMAGES, DLCTL_BGSOUNDS, DLCTL_VIDEOS];
UserInterfaceOptions := [];
FEnableDDE := False;
end;
destructor TEmbeddedWb.Destroy;
begin
DeAllocateHWnd(DDEHwnd);
FPrintOptions.HTMLHeader.Free;
FPrintoptions.Margins.Free;
FPrintoptions.Free;
unhook;
RemoveUserAgent;
{$IFDEF VER120}
disablemessagehandler;
{$ENDIF}
inherited;
end;
function RegisterMIMEFilter(clsid: TGUID; MIME: PWideChar): HRESULT;
begin
CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, MimeFactory);
CoInternetGetSession(0, MimeInternetSession, 0);
Result := MIMEInternetSession.RegisterMimeFilter(MimeFactory, Clsid, MIME);
end;
function UnregisterMIMEFilter(MIME: PWideChar): HRESULT;
begin
Result := MIMEInternetSession.UnregisterMimeFilter(MIMEFactory, MIME);
end;
function RegisterNameSpace(clsid: TGUID): HRESULT;
begin
CoGetClassObject(Clsid, CLSCTX_SERVER, nil, IClassFactory, NSFactory);
CoInternetGetSession(0, NSInternetSession, 0);
Result := NSInternetSession.RegisterNameSpace(NSFactory, Clsid, 'http', 0, nil, 0);
end;
function UnregisterNameSpace: HRESULT;
begin
Result := NSInternetSession.UnregisterNameSpace(NSFactory, 'http');
end;
procedure TEmbeddedWB.Hook;
begin
if (csDesigning in ComponentState) then exit;
FParentform := TForm(Owner);
if (FParentForm <> nil) and (FParentForm.HandleAllocated) then
begin
FOldWindowProc := FParentForm.WindowProc;
FParentForm.WindowProc := FormWndProc;
end;
end;
procedure TEmbeddedWB.UnHook;
begin
if (csDesigning in ComponentState) then exit;
if (FParentForm <> nil) and (FParentForm.HandleAllocated) then
FParentForm.WindowProc := FOldWindowProc;
// FOldWindowProc := nil;
FParentform := nil;
end;
procedure TEmbeddedWB.DDEWndProc(var AMsg: TMessage);
begin
with AMsg do
if (Msg = WM_DDE_INITIATE) and FEnableDDE
then DDEInitiate(wparam, lparam)
else
Result := DefWindowProc(DDEHWND, msg, wParam, lParam);
end;
procedure TEmbeddedWB.FormWndProc(var AMsg: TMessage);
var
i: Integer;
wnd: Integer;
S: string;
Msg: TWmActivate;
begin
if AMsg.Msg = WM_ACTIVATE then begin
Msg := TWmActivate(AMsg);
if Msg.Active = 0 then
begin
wnd := Msg.ActiveWindow;
SetLength(S, 80);
SetLength(S, GetClassName(Wnd, PChar(S), Length(S)));
if (S = '#32770') then
begin
if ReplaceCaption then
begin
SendMessage(wnd, WM_SETICON, ICON_SMALL, Forms.Application.Icon.Handle);
I := GetWindowTextLength(wnd);
SetLength(S, I + 1);
GetWindowText(Wnd, PChar(S), I + 1);
S := StringReplace(S, 'Microsoft ', '', []);
S := StringReplace(S, 'Internet Explorer', Forms.Application.Title, []);
SetWindowText(Wnd, Pchar(S));
end;
if InvokingPageSetup then
begin
InvokingPagesetup := False;
if PrintingWithOptions then
begin
SetWindowPos(Wnd, 0, -600, 0, 0, 0, 0);
PrintingWithOptions := False;
end;
if PrintOptions.Orientation = poPortrait then
SendDlgItemMessage(Wnd, $0420, BM_CLICK, 0, 0) else
SendDlgItemMessage(Wnd, $0421, BM_CLICK, 0, 0);
SetDlgItemText(wnd, $1FD3, PChar(PrintOptions.Header));
SetDlgItemText(wnd, $1FD5, PChar(PrintOptions.Footer));
SetDlgItemText(wnd, $0483, PrintMarginStr(PrintOptions.Margins.Left));
SetDlgItemText(wnd, $0484, PrintMarginStr(PrintOptions.Margins.top));
SetDlgItemText(wnd, $0485, PrintMarginStr(PrintOptions.Margins.Right));
SetDlgItemText(wnd, $0486, PrintMarginStr(PrintOptions.Margins.Bottom));
if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion > 4) then
PostMessage(FindWindowEx(wnd, 0, Pchar('Button'), nil), BM_CLICK, 0, 0) //Win2000
else SendDlgItemMessage(Wnd, 1, BM_CLICK, 0, 0);
end;
end;
if not PrintingWithOptions and (wnd <> 0) and Assigned(FOnShowDialog) then FOnShowDialog(self, Wnd);
end;
end;
FOldWindowProc(AMsg);
end;
function TEmbeddedWB.QueryService(const rsid, iid: TGuid; out Obj): HResult;
begin
if Assigned(FOnQueryService) then
Result := FOnQueryService(rsid, iid, IUnknown(obj)) else
Result := E_NOINTERFACE;
end;
function TEmbeddedWB.ShowMailClient: Boolean;
begin
result := OpenClient('Mail');
end;
function TEmbeddedWB.ShowNewsClient: Boolean;
begin
result := OpenClient('News');
end;
function TEmbeddedWB.ShowAddressBook: Boolean;
begin
result := OpenClient('Contacts');
end;
function TEmbeddedWB.ShowCalendar: Boolean;
begin
result := OpenClient('Calendar');
end;
function TEmbeddedWB.ShowInternetCall: Boolean;
begin
result := OpenClient('Internet Call');
end;
function TEmbeddedWB.OpenClient(Client: string): Boolean;
var
s, params, Exec: string;
begin
Result := FALSE;
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('Software/Clients/' + Client, FALSE);
S := ReadString('');
CloseKey;
OpenKey('Software/Clients/' + Client + '/' + S + '/shell/open/command', FALSE);
S := ReadString('');
CloseKey;
if S <> '' then begin
if Pos('/', S) > 0 then begin
Exec := system.Copy(S, 1, Pos('/', S) - 2);
Params := system.Copy(s, Length(exec) + 1, length(S));
end else begin
Exec := S;
Params := '';
end;
Result := TRUE;
shellExecute(handle, 'open', Pchar(Exec), pChar(Params), '', SW_SHOW);
end;
finally
Free;
end;
end;
procedure TEmbeddedWB.PrintPreView;
// IE 5.5 only
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.SetDownloadOptions(const Value:
TDownloadControlOptions);
begin
FDownloadControlOptions := Value;
UpdateDownloadControlValue;
{$IFDEF VER120}
(Application_ as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ELSE}
(Application as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ENDIF}
end;
procedure TEmbeddedWB.SetUserInterfaceOptions(const Value:
TUserInterfaceOptions);
begin
FUserInterfaceOptions := Value;
UpdateUserInterfaceValue;
{$IFDEF VER120}
(Application_ as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ELSE}
(Application as IOleControl).OnAmbientPropertyChange(DISPID_AMBIENT_DLCONTROL);
{$ENDIF}
end;
procedure TEmbeddedWB.UpdateDownloadControlValue;
const
acardDownloadControlValues: array[TDownloadControlOption] of Cardinal =
($00000010, $00000020, $00000040, $00000080,
$00000100, $00000200, $00000400, $00000800,
$00001000, $00002000, $00004000, $00008000,
$00010000, $00020000, $00040000, $10000000,
$20000000, $40000000, $80000000);
var
i: TDownloadControlOption;
begin
FDownloadOptionValue := 0;
if (FDownloadControlOptions <> []) then
for i := Low(TDownloadControlOption) to High(TDownloadControlOption)
do
if (i in FDownloadControlOptions) then
Inc(FDownloadOptionValue, acardDownloadControlValues);
end;
procedure TEmbeddedWB.UpdateUserInterfaceValue;
const
acardUserInterfaceValues: array[TUserInterfaceOption] of Cardinal =
($00000001, $00000002, $00000004, $00000008,
$00000010, $00000020, $00000040, $00000080,
$00000100, $00000200, $00000400, $00000800,
$00001000, $00002000, $00004000, $00010000, $00020000);
var
i: TUserInterfaceOption;
begin
FUserInterfaceValue := 0;
if (FUserInterfaceOptions <> []) then
for i := Low(TUserInterfaceOption) to High(TUserInterfaceOption) do
if (i in FUserInterfaceOptions) then
Inc(FUserInterfaceValue, acardUserInterfaceValues);
end;
function TEmbeddedWB.IsGlobalOffline: boolean;
var
dwState: DWORD;
dwSize: DWORD;
begin
dwState := 0;
dwSize := SizeOf(dwState);
result := false;
if (InternetQueryOption(nil, INTERNET_OPTION_CONNECTED_STATE, @dwState,
dwSize)) then
if ((dwState and INTERNET_STATE_DISCONNECTED_BY_USER) <> 0) then
result := true;
end;
procedure TEmbeddedWB.SetGlobalOffline(Value: Boolean);
const
INTERNET_STATE_DISCONNECTED_BY_USER = $10;
ISO_FORCE_DISCONNECTED = $1;
INTERNET_STATE_CONNECTED = $1;
var
ci: TInternetConnectedInfo;
dwSize: DWORD;
begin
dwSize := SizeOf(ci);
if (Value) then begin
ci.dwConnectedState := INTERNET_STATE_DISCONNECTED_BY_USER;
ci.dwFlags := ISO_FORCE_DISCONNECTED;
end else begin
ci.dwFlags := 0;
ci.dwConnectedState := INTERNET_STATE_CONNECTED;
end;
InternetSetOption(nil, INTERNET_OPTION_CONNECTED_STATE, @ci, dwSize);
end;
function SaveDocToStream(Doc: IDispatch; var AStream: TStream): HResult;
var
IpStream: IPersistStreamInit;
begin
if Doc <> nil then begin
IpStream := Doc as IPersistStreamInit;
Result := IpStream.save(TStreamAdapter.Create(AStream), TRUE);
end else Result := S_FALSE;
end;
function TEmbeddedWB.SaveToStream(AStream: TStream): HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(Document) then
Result := SaveDocToStream(Document, AStream)
else Result := S_FALSE;
end;
function SaveDocToStrings(Doc: IDispatch; var AStrings: TStrings): HResult;
var
IpStream: IPersistStreamInit;
AStream: TMemoryStream;
begin
AStream := TMemoryStream.Create;
try
IpStream := doc as IPersistStreamInit;
if not Assigned(IpStream) then Result := S_FALSE else
if Succeeded(IpStream.save(TStreamadapter.Create(AStream), TRUE))
then begin
AStream.Seek(0, 0);
AStrings.LoadFromStream(AStream);
Result := S_OK;
end else Result := S_FALSE;
except
Result := S_FALSE;
end;
AStream.Free;
end;
function TEmbeddedwb.SaveFrameToStream(FrameNo: Integer; AStream: TStream): HRESULT;
var
iw: IWebbrowser2;
begin
Result := S_FALSE;
iw := Getframe(frameNo);
if (iw <> nil) and assigned(iw.Document) then
Result := SaveDocToStream(iw.Document, AStream)
end;
function TEmbeddedwb.SaveFrameToStrings(FrameNo: Integer; AStrings: TStrings): HRESULT;
var
iw: Iwebbrowser2;
begin
Result := S_FALSE;
iw := Getframe(frameNo);
if (iw <> nil) and assigned(iw.Document) then
Result := SaveDocToStrings(iw.Document, AStrings);
end;
function TEmbeddedwb.SaveFrameToFile(FrameNo: Integer; const Fname: string): HRESULT;
var
Iw: IWebbrowser2;
PFile: IPersistFile;
begin
iw := Getframe(frameNo);
if (iw <> nil) and assigned(iw.Document) then begin
PFile := iw.Document as IPersistFile;
Result := PFile.Save(StringToOleStr(FName), False);
end else Result := S_FALSE;
end;
function SaveDocToFile(Doc: IDispatch; const Fname: string): HResult;
var
PFile: IPersistFile;
begin
PFile := Doc as IPersistFile;
Result := PFile.Save(StringToOleStr(FName), False);
end;
function TEmbeddedWB.SaveToFile(const Fname: string): HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(Document) then
begin
Result := SaveDocToFile(Document, FName);
end else Result := S_FALSE;
end;
function TEmbeddedWB.SaveToStrings(AStrings: TStrings): HRESULT;
begin
while ReadyState <> READYSTATE_COMPLETE do
Forms.Application.ProcessMessages;
if Assigned(document) then
Result := SaveDocToStrings(Document, AStrings)
else Result := S_FALSE;
end;
function TEmbeddedWb.LoadFrameFromStrings(Frameno: Integer; const AStrings: TStrings): HResult;
var
iw: IWebbrowser2;
M: TMemoryStream;
begin
Result := S_FALSE;
iw := GetFrame(Frameno);
if (iw <> nil) and assigned(iw.document) then begin
M := TMemoryStream.Create;
try
AStrings.SaveToStream(M);
M.seek(0, 0);
Result := (iw.Document as IPersistStreamInit).Load(TStreamadapter.Create(M));
except
Result := S_FALSE;
end;
M.free;
end;
end;
function TEmbeddedWb.LoadFromStrings(const AStrings: TStrings): HResult;
var
M: TMemoryStream;
begin
if not Assigned(document) then AssignDocument;
M := TMemoryStream.Create;
try
AStrings.SaveToStream(M);
Result := LoadFromStream(M);
except
Result := S_FALSE;
end;
M.free;
end;
function TEmbeddedWb.LoadFrameFromStream(FrameNo: Integer; AStream: TStream): HRESULT;
var
iw: IWebbrowser2;
begin
Result := S_FALSE;
iw := Getframe(frameNo);
if (iw <> nil) then if Assigned(iw.Document) then
begin
AStream.seek(0, 0);
Result := (iw.Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream));
end;
end;
function TEmbeddedWb.LoadFromStream(const AStream: TStream): HRESULT;
begin
if not Assigned(Document) then AssignDocument;
AStream.seek(0, 0);
Result := (Document as IPersistStreamInit).Load(TStreamadapter.Create(AStream));
end;
procedure TEmbeddedWb.AssignDocument;
begin
Go('about:blank');
while readystate <> READYSTATE_COMPLETE do Forms.Application.ProcessMessages;
end;
procedure TEmbeddedWb.SetFocusToDoc;
begin
if Document <> nil then
with {$IFDEF VER120}Application_{$ELSE}Application{$ENDIF} as IOleobject do
DoVerb(OLEIVERB_UIACTIVATE, nil, Self, 0, Handle, GetClientRect);
end;
{$IFDEF VER120}
procedure TEmbeddedWb.EnableMessagehandler;
begin
if not bMsgHandler then
begin
SaveMessage := Forms.Application.OnMessage;
Forms.Application.OnMessage := IeMessagehandler;
bMsgHandler := True;
end;
end;
procedure TEmbeddedWB.DisableMessageHandler;
begin
if bMsgHandler then
begin
Forms.Application.onMessage := Savemessage;
bMsgHandler := False;
end;
end;
{$ENDIF}
///BEGIN >>>>> Messagehandler by Mathias Walter - walter@coint.de >>>>>///
procedure TEmbeddedWB.WBWndProc(var Message: TMessage);
const
StdKeys = [VK_RETURN, VK_BACK]; { standard keys }
ExtKeys = [VK_LEFT, VK_RIGHT]; { extended keys }
fExtended = $01000000; { extended key flag }
var
bClose: Boolean;
{$IFNDEF VER120}
WinMsg: TMsg;
{$ENDIF}
begin
with Message do
begin
{$IFNDEF VER120}
if (Msg >= (CN_BASE + WM_KEYFIRST)) and (Msg <= (CN_BASE + WM_DEADCHAR)) then
begin
WinMsg.hwnd := Handle;
WinMsg.message := Msg - CN_BASE;
WinMsg.wParam := wParam;
WinMsg.lParam := lParam;
WinMsg.time := GetMessageTime;
WinMsg.pt.x := $115DE1F1;
WinMsg.pt.y := $115DE1F1;
if not ((wParam in StdKeys) or
(wParam in ExtKeys) and ((lParam and fExtended) = fExtended)) then
with Application as IOleInPlaceActiveObject do
Result := Integer(TranslateAccelerator(WinMsg) = S_OK);
end
else
{$ENDIF}
case Msg of
WM_CLOSE: begin
bClose := True;
if Assigned(FOnCloseQuery) then
FOnCloseQuery(Self, bClose);
if bClose then
OldWBWndProc(Message);
end;
WM_DDE_EXECUTE: DDEExecute(wparam, lparam);
WM_DDE_TERMINATE: DDETerminate(wparam, lparam);
else
OldWBWndProc(Message);
end;
end;
end;
{$IFDEF VER120}
procedure TEmbeddedWB.IEMessageHandler(var Msg: TMsg; var Handled: Boolean);
{ fixes the malfunction of some keys within webbrowser control }
const
StdKeys = [VK_TAB, VK_RETURN]; { standard keys }
ExtKeys = [VK_DELETE, VK_BACK, VK_LEFT, VK_RIGHT]; { extended keys }
fExtended = $01000000; { extended key flag }
begin
Handled := False;
with Msg do
if ((Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)) and
((wParam in StdKeys) or (GetKeyState(VK_CONTROL) < 0) or
(wParam in ExtKeys) and ((lParam and fExtended) = fExtended)) then
try
if IsChild(Handle, hWnd) then
{ handles all browser related messages }
begin
with Application_ as IOleInPlaceActiveObject do
Handled := TranslateAccelerator(Msg) = S_OK;
if not Handled then
begin
Handled := True;
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
except end;
end; // IEMessageHandler
{$ENDIF}
///END <<<<<< Messagehandler by Mathias Walter - walter@coint.de <<<<<///
procedure TEmbeddedWb.NavigateFolder(CSIDL: Integer);
var
sFolder: PITemIdList;
begin
SHGetSpecialFolderLocation(0, CSIDL, SFolder);
NavigatePidl(SFolder);
CoTaskMemFree(SFolder);
end;
procedure TEmbeddedWB.NavigatePidl(pidl: PItemIdList);
var
VaEmpty, vaPidl: Olevariant;
psa: PSafeArray;
cbData: UINT;
begin
cbdata := GetPidlSize(pidl);
psa := SafeArrayCreateVector(VT_UI1, 0, cbData);
if (psa <> nil) then begin
CopyMemory(psa.pvData, pidl, cbData);
VariantInit(vaPidl);
TVariantArg(vaPidl).vt := VT_ARRAY or VT_UI1;
TVariantArg(vaPidl).parray := psa;
Navigate2(vaPidl, vaEmpty, vaEmpty, vaEmpty, vaEmpty);
VariantClear(vaPidl);
end;
end;
procedure TEmbeddedWB.Go(Url: string);
var
_URL, Flags, TargetFrameName, PostData, Headers: Olevariant;
begin
_URL := Url;
Flags := 0; TargetFrameName := 0; Postdata := 0; Headers := 0;
Navigate2(_URL, Flags, TargetFrameName, PostData, Headers);
end;
procedure TEmbeddedWB.InvokeCMD(InvokeIE: Boolean; Value1, Value2: Integer; var vaIn, vaOut: OleVariant);
var
CmdTarget: IOleCommandTarget;
PtrGUID: PGUID;
begin
New(PtrGUID);
if InvokeIE then PtrGUID^ := CLSID_WebBrowser else
PtrGuid := PGUID(nil);
if Document <> nil then
try
Document.QueryInterface(IOleCommandTarget, CmdTarget);
if CmdTarget <> nil then
try
CmdTarget.Exec(PtrGuid, Value1, Value2, vaIn, vaOut);
finally
CmdTarget._Release;
end;
except end;
Dispose(PtrGUID);
end;
procedure TEmbeddedWB.Print;
var
vaIn, vaOut: Olevariant;
HtmlText: string;
Stream: IStream;
Dummy: Int64;
Psa: PSafeArray;
begin
HtmlText := PrintOptions.HtmlHeader.Text;
CreateStreamOnHGlobal(0, TRUE, Stream);
Stream.Write(Pchar(HTMLText), length(HTMLText), @Dummy);
Stream.Seek(0, STREAM_SEEK_SET, Dummy);
SafeArrayCopy(PSafeArray(TVarData(VarArrayOf([FPrintOptions.Header, FPrintOptions.Footer, Stream as IUnknown])).VArray), psa);
TVarData(VaIn).VType := varArray or varByRef;
SafeArrayCopy(psa, PSafeArray(TVarData(VaIn).VArray));
InvokeCmd(FALSE, OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;
procedure TEmbeddedWB.PrintSetup;
var
vaIn, vaOut: Olevariant;
HtmlText: string;
Stream: IStream;
Dummy: Int64;
Psa: PSafeArray;
begin
HtmlText := PrintOptions.HtmlHeader.Text;
CreateStreamOnHGlobal(0, TRUE, Stream);
Stream.Write(Pchar(HTMLText), length(HTMLText), @Dummy);
Stream.Seek(0, STREAM_SEEK_SET, Dummy);
SafeArrayCopy(PSafeArray(TVarData(VarArrayOf([FPrintOptions.Header, FPrintOptions.Footer, Stream as IUnknown])).VArray), psa);
TVarData(VaIn).VType := varArray or varByRef;
SafeArrayCopy(psa, PSafeArray(TVarData(VaIn).VArray));
InvokeCmd(FALSE, OLECMDID_PRINT, OLECMDEXECOPT_PROMPTUSER, vaIn, vaOut);
end;
procedure TEmbeddedWB.PageSetup(UsePrintOptions: Boolean);
var
vaIn, vaOut: Olevariant;
begin
if UsePrintOptions then InvokingPageSetup := True;
InvokeCmd(FALSE, OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.OpenDialog;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_OPEN, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.SaveDialog;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.ViewSource;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(TRUE, HTMLID_VIEWSOURCE, 0, vaIn, vaOut);
end;
procedure TEmbeddedWB.Options;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(TRUE, HTMLID_OPTIONS, 0, vaIn, vaOut);
end;
procedure TEmbeddedWB.Properties;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.Find;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(TRUE, HTMLID_FIND, 0, vaIn, vaOut);
end;
procedure TEmbeddedWB.Copy;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_COPY, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.SelectAll;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_SELECTALL, OLECMDEXECOPT_DODEFAULT, vaIn, vaOut);
end;
procedure TEmbeddedWB.Zoom(ZoomValue: Integer);
var
vaIn, vaOut: Olevariant;
begin
if ZoomValue < ZoomRangeLow then vaIn := ZoomRangeLow else
if ZoomValue > ZoomRangeHigh then vaIn := ZoomRangeHigh else
vaIn := ZoomValue;
InvokeCmd(FALSE, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
end;
function TEmbeddedWB.ZoomRangeLow: Integer;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
result := LoWord(Dword(vaOut));
end;
function TEmbeddedWB.ZoomRangeHigh: Integer;
var
vaIn, vaOut: Olevariant;
begin
InvokeCmd(FALSE, OLECMDID_GETZOOMRANGE, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
result := HiWord(Dword(vaOut));
end;
function TEmbeddedWB.ZoomValue: Integer;
var
vaIn, vaOut: Olevariant;
begin
vaIn := null;
InvokeCmd(FALSE, OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
result := vaOut;
end;
// IDOCHOSTUIHANDLER
function TEmbeddedWB.ShowContextMenu(const dwID: DWORD; const ppt: PPOINT;
const pcmdtReserved: IUnknown; const pdispReserved: IDispatch): HRESULT;
begin
if Assigned(FOnShowContextmenu) then RESULT := FOnSHowContextmenu(dwID, ppt,
pcmdtreserved, pdispreserved) else
RESULT := S_FALSE;
end;
function TEmbeddedWB.GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT;
begin
pInfo.cbSize := SizeOf(pInfo);
pInfo.dwFlags := FUserInterfaceValue;
pInfo.dwDoubleClick := DOCHOSTUIDBLCLK_DEFAULT;
if Assigned(FOnGetHostInfo) then
Result := FOnGetHostInfo(pInfo) else
Result := S_OK;
end;
function TEmbeddedWB.ShowUI(const dwID: DWORD;
const pActiveObject: IOleInPlaceActiveObject;
const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
const pDoc: IOleInPlaceUIWindow): HRESULT;
begin
if Assigned(FOnShowUI) then
Result := FOnShowUI(dwID, pActiveObject, pCommandTarget, pFrame, pDoc)
else
Result := S_FALSE;
end;
function TEmbeddedWB.HideUI: HRESULT;
begin
if Assigned(FOnHideUI) then
Result := FOnHideUI else
Result := S_FALSE;
end;
function TEmbeddedWB.UpdateUI: HRESULT;
begin
if Assigned(FOnUpdateUI) then
Result := FOnUpdateUI else
Result := S_FALSE;
end;
function TEmbeddedWB.EnableModeless(const fEnable: BOOL): HRESULT;
begin
if Assigned(FOnEnableModeless) then
Result := FOnEnableModeless(fEnable) else
Result := S_FALSE;
end;
function TEmbeddedWB.OnDocWindowActivate(const fActivate: BOOL): HRESULT;
begin
if Assigned(FOnOnDocWindowActivate) then
Result := FOnOnDocWindowActivate(fActivate) else
Result := S_FALSE;
end;
function TEmbeddedWB.OnFrameWindowActivate(const fActivate: BOOL): HRESULT;
begin
if Assigned(FOnOnFrameWindowActivate) then
Result := FOnOnFrameWindowActivate(fActivate) else
Result := S_FALSE;
end;
function TEmbeddedWB.ResizeBorder(const prcBorder: PRECT;
const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT;
begin
if Assigned(FOnResizeBorder) then
Result := FOnResizeBorder(prcBorder, pUIWindow, fRameWindow) else
Result := S_FALSE;
end;
function TEmbeddedWB.TranslateAccelerator(const lpMsg: PMSG;
const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT;
begin
if Assigned(FOnTranslateAccelerator) then
Result := FOnTranslateAccelerator(lpMsg, pguidCmdGroup, nCmdID) else
Result := S_FALSE;
end;
function TEmbeddedWB.GetOptionKeyPath(var pchKey: POLESTR; const dw: DWORD): HRESULT;
begin
if Assigned(FOnGetOptionKeyPath) then
Result := FOnGetOptionKeyPath(pchKey, dw) else
Result := S_FALSE;
end;
function TEmbeddedWB.GetDropTarget(const pDropTarget: IDropTarget;
out ppDropTarget: IDropTarget): HRESULT;
begin
if Assigned(FOnGetDropTarget) then
Result := FOnGetDropTarget(pDropTarget, ppDropTarget) else
Result := S_OK;
end;
function TEmbeddedWB.GetExternal(out ppDispatch: IDispatch): HRESULT;
begin
if Assigned(FOnGetExternal) then
Result := FOnGetExternal(ppDispatch) else
Result := S_FALSE;
end;
function TEmbeddedWB.TranslateUrl(const dwTranslate: DWORD;
const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT;
begin
if Assigned(FOnTranslateUrl) then
Result := FOnTranslateUrl(dwTranslate, pchUrlIn, ppchUrlOut) else
Result := S_FALSE;
end;
function TEmbeddedWB.FilterDataObject(const pDO: IDataObject;
out ppDORet: IDataObject): HRESULT;
begin
if Assigned(FOnFilterDataObject) then
Result := FOnFilterDataObject(pDO, ppDORet) else
Result := S_FALSE;
end;
// IDOCHOSTSHOWUI
function TEmbeddedWB.ShowMessage(hwnd: THandle; lpstrText: POLESTR;
lpstrCaption: POLESTR; dwType: longint; lpstrHelpFile: POLESTR;
dwHelpContext: longint; var plResult: LRESULT): HRESULT;
begin
if Assigned(FOnShowMessage) then
Result := FOnShowMessage(hwnd, lpstrText, lpStrCaption, dwType, lpStrHelpFile, dwHelpContext, plResult) else
Result := S_FALSE;
end;
function TEmbeddedWB.ShowHelp(hwnd: THandle; pszHelpFile: POLESTR;
uCommand: integer; dwData: longint; ptMouse: TPoint;
var pDispatchObjectHit: IDispatch): HRESULT;
begin
Result := S_OK;
if Assigned(FOnShowHelp) then
Result := FOnShowHelp(hwnd, pszHelpFile, uCommand, dwData, ptMouse, pDispatchObjectHit) else
if FHelpFile <> '' then HtmlHelp(hwnd, Pchar(FHelpFile), ucommand, dwData) else
Result := S_FALSE;
end;
// IDISPATCH methods
function TEmbeddedWB.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
if Assigned(FOnGetIdsofNames) then
Result := FOnGetIdsofNames(IID, Names, NameCount, LocaleID, DispIds) else
result := E_NotImpl;
end;
function TEmbeddedWB.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
if Assigned(FOnGetTypeInfo) then
Result := FOnGetTypeInfo(Index, LocaleID, ITypeInfo(TypeInfo)) else
begin
Result := E_NOTIMPL;
pointer(TypeInfo) := nil;
end;
end;
function TEmbeddedWB.GetTypeInfoCount(out Count: Integer): HResult;
begin
if Assigned(FOnGetTypeInfoCount) then
Result := FOnGetTypeInfoCount(Count) else
begin
Result := E_NOTIMPL;
Count := 0;
end;
end;
function TEmbeddedWB.Invoke(DispID: Integer;
const IID: TGUID;
LocaleID: Integer;
Flags: Word;
var Params;
VarResult, ExcepInfo,
ArgErr: Pointer): HResult;
begin
Result := S_OK;
if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) and
(DispId = DISPID_AMBIENT_DLCONTROL) then
PVariant(VarResult)^ := FDownloadOptionValue
else
if Assigned(FOnInvoke) then
Result := FOnInvoke(DispId, IID, LocaleID, Flags, TagDispParams(Params),
VarResult, ExcepInfo, ArgErr)
else
Result := inherited Invoke(DispID, IID, LocaleID, Flags, Params,
VarResult, ExcepInfo, ArgErr);
end;
procedure Register;
begin
RegisterComponents({$IFDEF VER120} 'ActiveX'{$ELSE} 'Internet'{$ENDIF}, [TEmbeddedWB]);
end;
{ TPrintOptions }
procedure TPrintOptions.SetHTMLHeader(const Value: Tstrings);
begin
FHTMLHeader.Assign(Value);
end;
function DeleteFirstCacheEntry(var H: THandle): DWORD;
var
T: PInternetCacheEntryInfo;
D: DWord;
begin
Result := S_OK;
H := 0;
D := 0;
FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, nil, @D, nil, nil, nil);
GetMem(T, D);
try
H := FindFirstUrlCacheEntryEx(nil, 0, URLCACHE_FIND_DEFAULT_FILTER, 0, T, @D, nil, nil, nil);
if (H = 0) then Result := GetLastError else DeleteUrlCacheEntry(T^.lpszSourceUrlname);
finally
FreeMem(T, D)
end;
end;
function DeleteNextCacheEntry(H: THandle): DWORD;
var
T: PInternetCacheEntryInfo;
D: DWORD;
begin
Result := S_OK;
D := 0;
FindnextUrlCacheEntryEx(H, nil, @D, nil, nil, nil);
GetMem(T, D);
try
if not FindNextUrlCacheEntryEx(H, T, @D, nil, nil, nil)
then Result := GetLastError else DeleteUrlCacheEntry(T^.lpszSourceUrlname);
finally
FreeMem(T, D)
end;
end;
procedure TEmbeddedWB.ClearCache;
var
H: THandle;
begin
if DeleteFirstCacheEntry(H) = S_OK then
repeat
until DeleteNextCacheEntry(H) = ERROR_NO_MORE_ITEMS;
FindCloseUrlCache(H)
end;
procedure TEmbeddedWB.ClearHistory;
var
HistoryStg: IUrlHistoryStg2;
begin
HistoryStg := CreateComObject(CLSID_CUrlHistory) as IUrlHistoryStg2;
HistoryStg.ClearHistory;
end;
function TEmbeddedWB.GetOverrideKeyPath(pchKey: POLESTR;
dw: DWORD): HRESULT;
begin
if Assigned(FOnGetOverrideKeyPath) then RESULT := FOnGetOverrideKeyPath(pchkey, dw) else
Result := S_OK;
end;
{$IFDEF USE_IOLECOMMANDTARGET}
function TEmbeddedWB.Exec(CmdGroup: PGUID; nCmdID, nCmdexecopt: DWORD;
const vaIn: OleVariant; var vaOut: OleVariant): HResult;
var
FCancel, FContinueScript, FShowDialog: Boolean;
pEventObj: IHTMLEventObj;
function GetProperty(const PropName: WideString): OLEVariant;
var
Dispparams: TDispParams;
Disp, Status: Integer;
ExcepInfo: TExcepInfo;
PPropName: PWideChar;
begin
Dispparams.rgvarg := nil;
Dispparams.rgdispidNamedArgs := nil;
Dispparams.cArgs := 0;
Dispparams.cNamedArgs := 0;
PPropName := PWideChar(PropName);
Status := pEventObj.GetIDsOfNames(GUID_NULL, @PPropname, 1,
LOCALE_SYSTEM_DEFAULT, @Disp);
if Status = 0 then
begin
Status := pEventObj.Invoke(disp, GUID_NULL, LOCALE_SYSTEM_DEFAULT, DISPATCH_PROPERTYGET,
Dispparams, @Result, @ExcepInfo, nil);
if Status <> 0 then DispatchInvokeError(Status, ExcepInfo);
end else
if Status = DISP_E_UNKNOWNNAME then
raise EOleError.CreateFmt('''%s'' not supported.', [PropName])
else
OleCheck(Status);
end;
begin
if (CmdGroup = nil) then
begin
Result := OLECMDERR_E_UNKNOWNGROUP;
exit;
end;
Result := OLECMDERR_E_NOTSUPPORTED;
if (ncmdID = OLECMDID_ONUNLOAD) and IsEqualGuid(cmdGroup^, CGID_EXPLORER) and
Assigned(FOnUnload) then FOnUnload(Self);
if IsEqualGuid(cmdGroup^, CGID_DocHostCommandHandler) then
begin
if Assigned(FOnRefresh) and ((nCmdID = 6041 {F5}) or (nCmdID = 6042 {ContextMenu}) or (nCmdID = 2300)) then
begin
FCancel := False;
FOnRefresh(self, nCmdID, FCancel);
if FCancel then Result := S_OK;
end else
case nCmdID of
OLECMDID_SHOWSCRIPTERROR:
if Assigned(FOnScriptError)
then begin
pEventObj := (Document as IHTMLDocument2).parentWindow.event;
if pEventObj <> nil then
begin
FContinueScript := True;
FShowDialog := True;
FOnScriptError(self,
GetProperty('errorline'),
GetProperty('errorCharacter'),
GetProperty('errorCode'),
GetProperty('errorMessage'),
GetProperty('errorUrl'),
FContinueScript, FShowDialog);
TVariantArg(vaOut).vt := VT_BOOL;
TVariantArg(vaOut).vbool := FContinueScript;
if not FShowDialog then Result := S_OK;
end;
end;
end;
end;
end;
function TEmbeddedWB.QueryStatus(CmdGroup: PGUID; cCmds: Cardinal;
prgCmds: POleCmd; CmdText: POleCmdText): HResult;
begin
result := S_OK;
end;
{$ENDIF}
initialization
Saved8087CW := Default8087CW;
{$IFDEF VER120}
bMsgHandler := False;
{$ENDIF}
OleInitialize(nil);
finalization
Set8087CW(Saved8087CW);
try
OleUninitialize;
except end;
end.
P
pcspace
Unregistered / Unconfirmed
GUEST, unregistred user!
各位大哥：
以上方法我都试过了，但是总是有这样那样的毛病！如果谁可以自己做一个Demo的
话最好，不管用什么方法。我在这里厚着脸皮提一下要求！在窗体上放一个TMemo控件，
一个TWebBrower控件，一个TButton控件，在Memo里面写入正确的Html代码（包含JS、
VBS特效），点击Button，在WebBrowser里面可以显示出来效果就可以！Memo里面的
代码就以 pcspace.myetang.com/JSTest.htm 的源代码为准！
如果谁做出来给我发到信箱里面： pcspace@sina.com
如果有控件，将控件一并发过来，如果有特殊说明，请写清楚！
以上方法我都试过了，但是总是有这样那样的毛病！如果谁可以自己做一个Demo的
话最好，不管用什么方法。我在这里厚着脸皮提一下要求！在窗体上放一个TMemo控件，
一个TWebBrower控件，一个TButton控件，在Memo里面写入正确的Html代码（包含JS、
VBS特效），点击Button，在WebBrowser里面可以显示出来效果就可以！Memo里面的
代码就以 pcspace.myetang.com/JSTest.htm 的源代码为准！
如果谁做出来给我发到信箱里面： pcspace@sina.com
如果有控件，将控件一并发过来，如果有特殊说明，请写清楚！
爱
爱元元的哥哥
Unregistered / Unconfirmed
GUEST, unregistred user!
不是吧，我把控件都贴出来了，你还不会用？
等靠要是不好的，我给你简单写一下。
安装控件，然后直接放到From上(web:TEmDedDedWb)
var
lstbegin:TStringlist;
begin
Url:='About:Blank';
Web.Navigate2(Url);
lstbegin:=TStringlist.create;
lstBegin.Append('<html>');
lstBegin.Append('<STYLE>');
lstBegin.Append('Body');
lstBegin.Append('{');
lstBegin.Append('SCROLLBAR-FACE-COLOR: #586979;');
lstBegin.Append('SCROLLBAR-HIGHLIGHT-COLOR: #6f8699;');
lstBegin.Append('SCROLLBAR-SHADOW-COLOR: #8ba8c0;');
lstBegin.Append('SCROLLBAR-ARROW-COLOR: #ffcc00;');
lstBegin.Append('SCROLLBAR-BASE-COLOR: #333333;');
lstBegin.Append('scrollbar-borderstyle: solid;');
lstBegin.Append('scrollbar-dark-shadow-color: #000000');
lstBegin.Append('}');
lstBegin.Append('</STYLE>');
lstBegin.Append('<body ');
lstBegin.Append('bgcolor='+ RGBColor(BackColor) + '>');
lstBegin.Append('</body>');
lstBegin.Append('</html>');
Web.loadfromstrings(lstBegin);
lstbegin.free;
end;
写了这么多，都快晕倒了，好了，你自己测试吧
等靠要是不好的，我给你简单写一下。
安装控件，然后直接放到From上(web:TEmDedDedWb)
var
lstbegin:TStringlist;
begin
Url:='About:Blank';
Web.Navigate2(Url);
lstbegin:=TStringlist.create;
lstBegin.Append('<html>');
lstBegin.Append('<STYLE>');
lstBegin.Append('Body');
lstBegin.Append('{');
lstBegin.Append('SCROLLBAR-FACE-COLOR: #586979;');
lstBegin.Append('SCROLLBAR-HIGHLIGHT-COLOR: #6f8699;');
lstBegin.Append('SCROLLBAR-SHADOW-COLOR: #8ba8c0;');
lstBegin.Append('SCROLLBAR-ARROW-COLOR: #ffcc00;');
lstBegin.Append('SCROLLBAR-BASE-COLOR: #333333;');
lstBegin.Append('scrollbar-borderstyle: solid;');
lstBegin.Append('scrollbar-dark-shadow-color: #000000');
lstBegin.Append('}');
lstBegin.Append('</STYLE>');
lstBegin.Append('<body ');
lstBegin.Append('bgcolor='+ RGBColor(BackColor) + '>');
lstBegin.Append('</body>');
lstBegin.Append('</html>');
Web.loadfromstrings(lstBegin);
lstbegin.free;
end;
写了这么多，都快晕倒了，好了，你自己测试吧
