FireMonkey Windows下的WebBrowser组件编写
来源：互联网 发布：裂脑人 知乎 编辑：程序博客网 时间：2024/05/21 06:25
其实FireMonkey非常好用, 但就是缺了WINDOWS下的浏览器组件, 有时程序可能需要一个嵌入式的框框, 而Delphi且没有为我们提供这个东东...咋整呢...
好像有大牛使用谷歌浏览器组件封装过一个唉, 具体不知道了,我也没看过, 听说还要带一大堆的dll文件, 貌似有几十M呢,.........好像用不着啊.........
那我们该怎么办呢....其实在FireMonkey的前身DxScene中有一个3d浏览器的例程, 不知道大家看过没有, 我是照着写了下, 不过是将浏览器封装在DLL中的,
这样可以必免引入vcl库了,,,,但不好就是要带一个dll走........实现了是实现了, 但感觉用着不咋爽,特别是大面积的还带有js自动刷新某些页面的时候就会发现
cpu占得很大, 绘图效果还不好了....
于是就有了一个想法, 能不能将浏览器组件冰封装在dll中的Form中呢.. 然后以子父窗口的形式来创建,,, 答案是肯定可以的, 接下来我们就开始实现吧
首先我们需要编写一个dll,, 在里面创建一个Form,再在 Form上放置一个浏览器组件, 将Form设置为无边框模式, Webbrowser设置为Client对齐
然后我们需要重新编写浏览器的事件, 如下
大家会发现少下sender这个参数, 其实我是故意不要的,因为也用不着, 呵呵, 这里我定义了浏览器最基本的一些事件, 然后该怎么办呢, 继续看吧
{***************************************************************************}{ }{ 功能：FMX.ZYJ 浏览器组件 }{ 名称：FMX.ZYJ.Win.WebBrowser.pas }{ 版本：1.1 }{ 环境：Win8.1 }{ 工具：Delphi XE3 AppMethod DelphiXE6 }{ 日期：2014/3/28 19:35:56 }{ 作者：ying32 }{ QQ ：1444386932 }{ 版权所有 (C) 2014-2014 ying32 All Rights Reserved }{ }{---------------------------------------------------------------------------}{ }{ 备注： Windows浏览器组件 }{ }{ }{ }{***************************************************************************}unit FMX.ZYJ.Win.WebBrowser;interfaceuses Winapi.Windows, WebBrowserUnit, System.SysUtils, System.Classes, System.Types, System.UITypes, FMX.Types, FMX.Controls, FMX.Forms;
type TWebDocumentComplete = procedure(const pDisp: IDispatch; var URL: OleVariant) of object; TWebStatusTextChange = procedure(const Text: WideString) of object; TWebTitleChange = procedure(const Text: WideString) of object; TWebVisible = procedure(Visible: WordBool) of object; TWebQuit = procedure of object; TWebPropertyChange = procedure(const szProperty: WideString) of object; TWebProgressChange = procedure(Progress, ProgressMax: Integer) of object; TWebNewWindow2 = procedure(var ppDisp: IDispatch; var Cancel: WordBool) of object; TWebNavigateComplete2 = procedure(const pDisp: IDispatch; var URL: OleVariant) of object; TWebFullScreen = procedure(FullScreen: WordBool) of object; TWebDownloadBegin = procedure of object; TWebDownloadComplete = procedure of object; TWebCommandStateChange = procedure(Command: Integer; Enable: WordBool) of object; TWebBeforeNavigate2 = procedure(const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool) of object;
接下来我们需要定义一些私有的变量,将这个事件以属性的方式重新输出到外面去
private FOnDocumentComplete: TWebDocumentComplete; FOnStatusTextChange: TWebStatusTextChange; FOnTitleChange: TWebTitleChange; FOnVisible: TWebVisible; FOnQuit: TWebQuit; FOnPropertyChange: TWebPropertyChange; FOnProgressChange: TWebProgressChange; FOnNewWindow2: TWebNewWindow2; FOnNavigateComplete2: TWebNavigateComplete2; FOnFullScreen: TWebFullScreen; FOnDownloadBegin: TWebDownloadBegin; FOnDownloadComplete: TWebDownloadComplete; FOnCommandStateChange: TWebCommandStateChange; FOnBeforeNavigate2: TWebBeforeNavigate2; public property OnDocumentComplete: TWebDocumentComplete read FOnDocumentComplete write FOnDocumentComplete; property OnStatusTextChange: TWebStatusTextChange read FOnStatusTextChange write FOnStatusTextChange; property OnTitleChange: TWebTitleChange read FOnTitleChange write FOnTitleChange; property OnVisible: TWebVisible read FOnVisible write FOnVisible; property OnQuit: TWebQuit read FOnQuit write FOnQuit; property OnPropertyChange: TWebPropertyChange read FOnPropertyChange write FOnPropertyChange; property OnProgressChange: TWebProgressChange read FOnProgressChange write FOnProgressChange; property OnNewWindow2: TWebNewWindow2 read FOnNewWindow2 write FOnNewWindow2; property OnNavigateComplete2: TWebNavigateComplete2 read FOnNavigateComplete2 write FOnNavigateComplete2; property OnFullScreen: TWebFullScreen read FOnFullScreen write FOnFullScreen; property OnDownloadBegin: TWebDownloadBegin read FOnDownloadBegin write FOnDownloadBegin; property OnDownloadComplete: TWebDownloadComplete read FOnDownloadComplete write FOnDownloadComplete; property OnCommandStateChange: TWebCommandStateChange read FOnCommandStateChange write FOnCommandStateChange; property OnBeforeNavigate2: TWebBeforeNavigate2 read FOnBeforeNavigate2 write FOnBeforeNavigate2; end;
好了, 我们已经建议好事件了, 接下来就是在浏览的事件中调用我们的这些事件, 这里给出一个参考, 其它都一样了
procedure TWebForm.wbDocumentComplete(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant);begin try if Assigned(OnDocumentComplete) then OnDocumentComplete(pDisp, URL); except end;end;
完成了以上我们的浏览器组件还不算呢, 接下来我们要导出这些东西, 在这里我是以标准的function导出的, 原来我打算创建一个类管理, 后来我虽然用了这个方法,但实际没多大用下, 大家将就着看吧
接下来我们编写创建浏览器的函数吧
function TWebWindowManager.BrowserCreate(AParent: Cardinal; AVisible: Boolean; ALeft, ATop, AWidth, AHeight: Integer): Cardinal;var LWeb: TWebForm;begin Result := 0; if not IsWindow(AParent) then Exit; LWeb := TWebForm.Create(Application); if Assigned(LWeb) then begin Windows.SetParent(LWeb.Handle, AParent); // 貌似有时无法前台,故有此函数调用 // Windows.SetForegroundWindow(AParent); SetWindowPos(LWeb.Handle, 0, ALeft, ATop, AWidth, AHeight, SWP_NOACTIVATE); if AVisible then ShowWindow(LWeb.Handle, SW_SHOWNORAML); FList.Add(LWeb); Result := Cardinal(LWeb);// Result := FList.Add(LWeb) + 1; end;end;
呵呵, 大家别理会注释掉的代码就好了. 那是以前写的方法....没去掉.....
释放掉
function TWebWindowManager.BrowserFree(Handle: Cardinal): Boolean;var P: Pointer;begin Result := False; P := GetItem(Handle); if Assigned(P) then begin TWebForm(P).Free; FList.Remove(P);// FList.Delete(Integer(Handle) - 1); Result := True; end;end;
再下来就是浏览器的几个方法了.
procedure TWebWindowManager.BrowserNavigateA(Handle: Cardinal; AURL: PAnsiChar);var P: Pointer;begin try P := GetItem(Handle); if Assigned(P) then TWebForm(P).wb.Navigate(AURL); except end;end;procedure TWebWindowManager.BrowserNavigateW(Handle: Cardinal; AURL: PWideChar);var P: Pointer;begin try P := GetItem(Handle); if Assigned(P) then TWebForm(P).wb.Navigate(AURL); except end;end;
实现方法很简单, 那事件呢? 其实一样也简单, 看下面
procedure TWebWindowManager.BrowserDocumentComplete(Handle: Cardinal; AEvent: TWebDocumentComplete);var P: Pointer;begin P := GetItem(Handle); if Assigned(P) then begin if (not Assigned(TWebForm(P).OnDocumentComplete)) or (@TWebForm(P).OnDocumentComplete <> @AEvent) then TWebForm(P).OnDocumentComplete := AEvent; end;end;
是不是简单啊, 其实的都类似了, 这里就不贴出来了
然后我们导出这些函数, 实际上我外面还重新编写了一个stdcall的函数...因为当时没想好,又懒得改, 所以....
exports BrowserCreate name 'webCreate', BrowserFree name 'webFree', BrowserSetVisible name 'webSetVisible', BrowserMove name 'webMove',
呵呵,我重命名了....
以上dll部分就编写好了, 接下来是函数申明... .这个就不用我写了吧.....
再下来就是编写FMX组件啦
这里我再一次重新定义了事件
type TWebDocumentCompleteEvent = procedure(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant) of object; TWebStatusTextChangeEvent = procedure(Sender: TObject; const Text: WideString) of object; TWebTitleChangeEvent = procedure(Sender: TObject; const Text: WideString) of object; TWebVisibleEvent = procedure(Sender: TObject; Visible: WordBool) of object; TWebQuitEvent = procedure(Sender: TObject) of object; TWebPropertyChangeEvent = procedure(Sender: TObject; const szProperty: WideString) of object; TWebProgressChangeEvent = procedure(Sender: TObject; Progress, ProgressMax: Integer) of object; TWebNewWindow2Event = procedure(Sender: TObject; var ppDisp: IDispatch; var Cancel: WordBool) of object; TWebNavigateComplete2Event = procedure(Sender: TObject; const pDisp: IDispatch; var URL: OleVariant) of object; TWebFullScreenEvent = procedure(Sender: TObject; FullScreen: WordBool) of object; TWebDownloadBeginEvent = procedure(Sender: TObject) of object; TWebDownloadCompleteEvent = procedure(Sender: TObject) of object; TWebCommandStateChangeEvent = procedure(Sender: TObject; Command: Integer; Enable: WordBool) of object; TWebBeforeNavigate2Event = procedure(Sender: TObject; const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool) of object;
下面是组件类啦
TZYJWebBrowser = class(TControl) strict private FWebHandle: Cardinal; private FOnDocumentComplete: TWebDocumentCompleteEvent; FOnStatusTextChange: TWebStatusTextChangeEvent; FOnTitleChange: TWebTitleChangeEvent; FOnVisible: TWebVisibleEvent; FOnQuit: TWebQuitEvent; FOnPropertyChange: TWebPropertyChangeEvent; FOnProgressChange: TWebProgressChangeEvent; FOnNewWindow2: TWebNewWindow2Event; FOnNavigateComplete2: TWebNavigateComplete2Event; FOnFullScreen: TWebFullScreenEvent; FOnDownloadBegin: TWebDownloadBeginEvent; FOnDownloadComplete: TWebDownloadCompleteEvent; FOnCommandStateChange: TWebCommandStateChangeEvent; FOnBeforeNavigate2: TWebBeforeNavigate2Event; function GetDefaultInterface: IDispatch; function GetDocument: IDispatch; protected procedure Resize; override; procedure Paint; override; procedure SetVisible(const Value: Boolean); override; procedure FDocumentComplete(const pDisp: IDispatch; var URL: OleVariant); procedure FStatusTextChange(const Text: WideString); procedure FTitleChange(const Text: WideString); procedure FVisible2(Visible: WordBool); procedure FQuit(); procedure FPropertyChange(const szProperty: WideString); procedure FProgressChange(Progress, ProgressMax: Integer); procedure FNewWindow2(var ppDisp: IDispatch; var Cancel: WordBool); procedure FNavigateComplete2(const pDisp: IDispatch; var URL: OleVariant); procedure FFullScreen(FullScreen: WordBool); procedure FDownloadBegin(); procedure FDownloadComplete(); procedure FCommandStateChange(Command: Integer; Enable: WordBool); procedure FBeforeNavigate2(const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool); public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure GoHome; procedure GoBack; procedure GoForward; procedure GoSearch; procedure Stop; procedure Refresh; procedure CanvasToBuffer(DC: HDC); procedure Navigate(URL: string); property DefaultInterface: IDispatch read GetDefaultInterface; property Document: IDispatch read GetDocument; published property Action; property Align default TAlignLayout.alNone; property Anchors; property CanFocus default True; property CanParentFocus; property ClipChildren default False; property ClipParent default False; property DisableFocusEffect; property Height; property Locked default False; property Margins; property Opacity; property Padding; property Position; property RotationAngle; property RotationCenter; property Scale; property TabOrder; property Visible default True; property Width; property OnDocumentComplete: TWebDocumentCompleteEvent read FOnDocumentComplete write FOnDocumentComplete; property OnStatusTextChange: TWebStatusTextChangeEvent read FOnStatusTextChange write FOnStatusTextChange; property OnTitleChange: TWebTitleChangeEvent read FOnTitleChange write FOnTitleChange; property OnVisible: TWebVisibleEvent read FOnVisible write FOnVisible; property OnQuit: TWebQuitEvent read FOnQuit write FOnQuit; property OnPropertyChange: TWebPropertyChangeEvent read FOnPropertyChange write FOnPropertyChange; property OnProgressChange: TWebProgressChangeEvent read FOnProgressChange write FOnProgressChange; property OnNewWindow2: TWebNewWindow2Event read FOnNewWindow2 write FOnNewWindow2; property OnNavigateComplete2: TWebNavigateComplete2Event read FOnNavigateComplete2 write FOnNavigateComplete2; property OnFullScreen: TWebFullScreenEvent read FOnFullScreen write FOnFullScreen; property OnDownloadBegin: TWebDownloadBeginEvent read FOnDownloadBegin write FOnDownloadBegin; property OnDownloadComplete: TWebDownloadCompleteEvent read FOnDownloadComplete write FOnDownloadComplete; property OnCommandStateChange: TWebCommandStateChangeEvent read FOnCommandStateChange write FOnCommandStateChange; property OnBeforeNavigate2: TWebBeforeNavigate2Event read FOnBeforeNavigate2 write FOnBeforeNavigate2; end;
然后我们构造这个吧
constructor TZYJWebBrowser.Create(AOwner: TComponent);var Obj: TFmxObject; R: TRectF;begin inherited Create(AOwner); FWebHandle := 0; Width := 400; Height := 200; CanFocus := True; if not (csDesigning in ComponentState) then begin R := AbsoluteRect; Obj := AOwner as TFmxObject; while Obj.Parent <> nil do Obj := Obj.Parent; if (Obj <> nil) and (Obj is TCustomForm) then FWebHandle := webCreate(FmxHandleToHWND((Obj as TCustomForm).Handle), Visible, Round(R.Left), Round(R.Top), Round(R.Right - R.Left), Round(R.Bottom - R.Top)); if FWebHandle = 0 then raise Exception.Create('创建浏览器组件失败!'); // 下面的绑定浏览器的事件 webDocumentComplete(FWebHandle, FDocumentComplete); webStatusTextChange(FWebHandle, FStatusTextChange); webTitleChange(FWebHandle, FTitleChange); webVisible(FWebHandle, FVisible2); webQuit(FWebHandle, FQuit); webPropertyChange(FWebHandle, FPropertyChange); webProgressChange(FWebHandle, FProgressChange); webNewWindow2(FWebHandle, FNewWindow2); webNavigateComplete2(FWebHandle, FNavigateComplete2); webFullScreen(FWebHandle, FFullScreen); webDownloadBegin(FWebHandle, FDownloadBegin); webDownloadComplete(FWebHandle, FDownloadComplete); webCommandStateChange(FWebHandle, FCommandStateChange); webBeforeNavigate2(FWebHandle, FBeforeNavigate2); end;end;然后我们还要处理组件大小发生改变以使用浏览器大小随之改变
procedure TZYJWebBrowser.Resize;var R: TRectF;begin inherited; if not (csDesigning in ComponentState) then begin R := AbsoluteRect; webMove(FWebHandle, Round(R.Left), Round(R.Top), Round(R.Right - R.Left), Round(R.Bottom - R.Top)); end;end;
浏览器的可视,
procedure TZYJWebBrowser.SetVisible(const Value: Boolean);begin inherited; if not (csDesigning in ComponentState) then webSetVisible(FWebHandle, Value);end;
然后还有各个事件的传递, 这里只举几个例子. 其它都一样
procedure TZYJWebBrowser.FCommandStateChange(Command: Integer; Enable: WordBool);begin if Assigned(FOnCommandStateChange) then FOnCommandStateChange(Self, Command, Enable);end;procedure TZYJWebBrowser.FBeforeNavigate2(const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool);begin if Assigned(FOnBeforeNavigate2) then FOnBeforeNavigate2(Self, pDisp, URL, Flags, TargetFrameName, PostData, Headers, Cancel);end;function TZYJWebBrowser.GetDefaultInterface: IDispatch;begin Result := webDefaultInterface(FWebHandle);end;function TZYJWebBrowser.GetDocument: IDispatch;begin Result := webDocument(FWebHandle);end;procedure TZYJWebBrowser.GoBack;begin webGoBack(FWebHandle);end;
再然后我们就完成了....,看看效果吧
效果还是不错的, 不过有个缺点,当你的父对象被隐藏了, 子窗口确还在,,, 翻看了他所有的代码,也没找着地方有通知事件, 虽然可以有属性可以得到父控件是否隐藏了, 但难不成开个线程或者时钟去监视这个属性么, 我觉得不可行....所以需要自己处理下这个问题
0 0
- FireMonkey Windows下的WebBrowser组件编写
- FireMonkey下的WndProc实现
- 给FireMonkey的组件加上Hint功能
- 【Delphi】FireMonkey下的WndProc实现
- FireMonkey下的如何实现WndProc
- FireMonkey下的异形窗体拖动
- FireMonkey TrayIcon组件
- WebBrowser组件的execWB方法
- WebBrowser组件的execWB方法
- WebBrowser组件的execWB方法
- [delphi组件] Webbrowser的使用
- windows下DLL的编写
- windows下批处理文件的编写
- Windows 下的 Makefile 编写
- FireMonkey的窗口Handle转为Windows窗口的Handle
- FireMonkey的窗口Handle转为Windows窗口的Handle
- FireMonkey开发: Android和IOS下的剪贴板实现
- FireMonkey开发: win下的窗口拖放实现
- java日志，需要知道的几件事(commons-logging,log4j,slf4j,logback)
- 努力的美
- 求安徽老乡妹子做女朋友。
- oracle中date日期转换比较
- IO流——2
- FireMonkey Windows下的WebBrowser组件编写
- POJ 3264 Balanced Lineup (RMQ分析)
- tcxgrid控件中drag a column header here to group by that column移除方法
- 计算机网络 3.运输层
- C# 反射详解:定义、创建对象、调用实例方法及静态方法
- 使用DBUtils编写通用的DAO【很有价值】
- Label Propagation Algorithm(LPA)
- 透析Java本质-谈类型转换的神秘
- judge loop in undirected graph
