Delphi 中TWebBrowser的扩展控件TExWebBrowser
主要扩展了3D界面、右键菜单、是否显示图片、是否支持JAVA等功能。
代码如下:
- unit ExtWebBrowser;
- interface
- uses
- Windows, SysUtils, Classes, Controls, OleCtrls, SHDocVw, ActiveX, Forms, URLMon;
- type
- TDocHostUIInfo = packed record
- cbSize : ULONG;
- dwFlags : DWORD;
- dwDoubleClick : DWORD;
- pchHostCss : polestr;
- pchHostNS : polestr;
- end;
- pDocHostUIInfo = ^TDocHostUIInfo;
- IDocHostUIHandler = interface(IUnknown)
- ['{BD3F23C0-D43E-11CF-893B-00AA00BDCE1A}']
- 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;
- end;
- ICustomDoc = interface (IUnknown)
- ['{3050F3F0-98B5-11CF-BB82-00AA00BDCE0B}']
- function SetUIHandler (const pUIHandler : IDocHostUIHandler) : HRESULT; stdcall;
- end;
- TExWebBrowser = class;
- TUIProperties = class (TPersistent)
- private
- fOwner : TExWebBrowser;
- fEnableContextMenu: boolean;
- fEnableScrollBars: boolean;
- fFlatScrollBars: boolean;
- fHas3DBorder: boolean;
- fOpenLinksInNewWindow: boolean;
- fEnableScripting: boolean;
- fShowImages: boolean;
- fShowActiveX: boolean;
- fEnableDownloadActiveX: boolean;
- fEnableJava: boolean;
- public
- constructor Create (AOwner : TExWebBrowser);
- published
- property EnableContextMenu : boolean read fEnableContextMenu write fEnableContextMenu;
- property EnableScrollBars : boolean read fEnableScrollBars write fEnableScrollBars;
- property FlatScrollBars : boolean read fFlatScrollBars write fFlatScrollBars;
- property Has3DBorder : boolean read fHas3DBorder write fHas3DBorder;
- property OpenLinksInNewWindow : boolean read fOpenLinksInNewWindow write fOpenLinksInNewWindow;
- property EnableScripting : boolean read fEnableScripting write fEnableScripting;
- property EnableJava : boolean read fEnableJava write fEnableJava;
- property EnableDownloadActiveX : boolean read fEnableDownloadActiveX write fEnableDownloadActiveX;
- property ShowImages : boolean read fShowImages write fShowImages default True;
- property ShowActiveX : boolean read fShowActiveX write fShowActiveX default True;
- end;
- TExWebBrowser = class(TWebBrowser, IDocHostUIHandler, IDispatch)
- private
- fUIProperties : TUIProperties;
- fURL : string;
- fInternetSession : IInternetSession;
- { IDispatch }
- function IDispatch.Invoke = Invoke;
- function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
- { IDocHostUIHandler }
- 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 GetURL: string;
- procedure SetURL(const Value: string);
- protected
- procedure Loaded; override;
- public
- constructor Create (AOwner : TComponent); override;
- destructor Destroy; override;
- procedure LoadFromString (const st : string);
- procedure LoadFromStream (s : TStream; takeOwnership : boolean = false);
- published
- property UIProperties : TUIProperties read fUIProperties write fUIProperties;
- property URL : string read GetURL write SetURL;
- end;
- implementation
- uses ComObj;
- const
- DOCHOSTUIFLAG_DIALOG = $00000001;
- DOCHOSTUIFLAG_DISABLE_HELP_MENU = $00000002;
- DOCHOSTUIFLAG_NO3DBORDER = $00000004;
- DOCHOSTUIFLAG_SCROLL_NO = $00000008;
- DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE = $00000010;
- DOCHOSTUIFLAG_OPENNEWWIN = $00000020;
- DOCHOSTUIFLAG_DISABLE_OFFSCREEN = $00000040;
- DOCHOSTUIFLAG_FLAT_SCROLLBAR = $00000080;
- DOCHOSTUIFLAG_DIV_BLOCKDEFAULT = $00000100;
- DOCHOSTUIFLAG_ACTIVATE_CLIENTHIT_ONLY = $00000200;
- DOCHOSTUIFLAG_OVERRIDEBEHAVIOURFACTORY = $00000400;
- DOCHOSTUIFLAG_CODEPAGELINKEDFONTS = $00000800;
- DOCHOSTUIFLAG_URL_ENCODING_DISABLE_UTF8 = $00001000;
- DOCHOSTUIFLAG_URL_ENCODING_ENABLE_UTF8 = $00002000;
- DOCHOSTUIFLAG_ENABLE_FORMS_AUTOCOMPLETE = $00004000;
- { TExWebBrowser }
- constructor TExWebBrowser.Create(AOwner: TComponent);
- ///var
- // Factory : IClassFactory;
- begin
- inherited Create (AOwner);
- fUIProperties := TUIProperties.Create (self);
- OleCheck (CoInternetGetSession (0, fInternetSession, 0));
- if fInternetSession <> Nil then
- begin
- // CoGetClassObject(Class_CIDMimeFilter, CLSCTX_SERVER, nil, IClassFactory, Factory);
- // OleCheck (fInternetSession.RegisterMimeFilter(Factory, Class_CIDMimeFilter, 'cid'));
- // OleCheck (fInternetSession.RegisterNameSpace(Factory, CLASS_CIDMIMEFilter, 'cid', 0, nil, 0))
- end
- end;
- destructor TExWebBrowser.Destroy;
- begin
- fUIProperties.Free;
- inherited;
- end;
- (*----------------------------------------------------------------------*
- | TExWebBrowser.EnableModeless |
- | |
- | IE calls this to tell us that our dialogs should be modeless. |
- *----------------------------------------------------------------------*)
- function TExWebBrowser.EnableModeless(const fEnable: BOOL): HRESULT;
- begin
- result := S_OK;
- end;
- (*----------------------------------------------------------------------*
- | TExWebBrowser.FilterDataObject |
- | |
- | IE calls this before putting data objects on the clipboard. It |
- | allows us to replace them or set them to nil. |
- | |
- | The function returns S_FALSE meaning we didn't replace the object |
- *----------------------------------------------------------------------*)
- function TExWebBrowser.FilterDataObject(const pDO: IDataObject;
- out ppDORet: IDataObject): HRESULT;
- begin
- ppDORet := Nil;
- result := S_FALSE;
- end;
- (*----------------------------------------------------------------------*
- | TExWebBrowser.GetDropTarget |
- | |
- | The IE control calls this when it's used as a drop target so we can |
- | provide a different ppDropTarget if we want. We don't. |
- | |
- | Parameters: |
- | const pDropTarget: IDropTarget; out ppDropTarget: IDropTarget
- | |
- | The function returns HRESULT
- *----------------------------------------------------------------------*)
- function TExWebBrowser.GetDropTarget(const pDropTarget: IDropTarget;
- out ppDropTarget: IDropTarget): HRESULT;
- begin
- ppDropTarget := Nil;
- result := E_NOTIMPL
- end;
- (*----------------------------------------------------------------------*
- | TExWebBrowser.GetExternal |
- | |
- | IE calls this to determine our IDispatch interface. We don't have |
- | one... |
- *----------------------------------------------------------------------*)
- function TExWebBrowser.GetExternal(out ppDispatch: IDispatch): HRESULT;
- begin
- ppDispatch := Application;
- result := S_OK
- end;
- function TExWebBrowser.GetHostInfo(var pInfo: TDOCHOSTUIINFO): HRESULT;
- begin
- FillChar (pInfo, SizeOf (pInfo), 0);
- pInfo.cbSize := sizeof (TDOCHOSTUIINFO);
- pInfo.cbSize := SizeOf(pInfo);
- pInfo.dwFlags := 0;
- if not UIProperties.EnableScrollBars then
- pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_SCROLL_NO;
- if UIProperties.FlatScrollBars then
- pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_FLAT_SCROLLBAR;
- if not UIProperties.Has3DBorder then
- pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_NO3DBORDER;
- if UIProperties.OpenLinksInNewWindow then
- pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_OPENNEWWIN;
- if not UIProperties.EnableScripting then
- pInfo.dwFlags := pInfo.dwFlags or DOCHOSTUIFLAG_DISABLE_SCRIPT_INACTIVE;
- result := S_OK;
- end;
- function TExWebBrowser.GetOptionKeyPath(var pchKey: POLESTR;
- const dw: DWORD): HRESULT;
- begin
- result := S_FALSE;
- end;
- function TExWebBrowser.GetURL: string;
- begin
- if (csDesigning in ComponentState) then
- result := fURL
- else
- result := self.LocationURL
- end;
- function TExWebBrowser.HideUI: HRESULT;
- begin
- result := S_OK;
- end;
- function TExWebBrowser.Invoke(DispID: Integer; const IID: TGUID;
- LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
- ArgErr: Pointer): HResult;
- const
- DISPID_AMBIENT_DLCONTROL = -5512;
- DLCTL_DLIMAGES = $00000010;
- DLCTL_NO_SCRIPTS = $00000080;
- DLCTL_NO_JAVA = $00000100;
- DLCTL_NO_RUNACTIVEXCTLS = $00000200;
- DLCTL_NO_DLACTIVEXCTLS = $00000400;
- DLCTL_DOWNLOADONLY = $00000800;
- var
- ort : HRESULT;
- dlc : Integer;
- begin
- result := inherited Invoke (DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr);
- if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then
- begin
- ort := result;
- result := S_OK;
- case DispID of
- (*
- DISPID_AMBIENT_USERMODE:
- PVariant(VarResult)^ := True; // not (csDesigning in ComponentState);
- *)
- DISPID_AMBIENT_DLCONTROL:
- begin
- if UIProperties.ShowImages then
- dlc := DLCTL_DLIMAGES
- else
- dlc := 0;
- if not UIProperties.EnableJava then
- dlc := dlc or DLCTL_NO_JAVA;
- if not UIProperties.EnableScripting then
- dlc := dlc or DLCTL_NO_SCRIPTS;
- if not UIProperties.EnableDownloadActiveX then
- dlc := dlc or DLCTL_NO_DLACTIVEXCTLS;
- if not UIPRoperties.ShowActiveX then
- dlc := dlc or DLCTL_NO_RUNACTIVEXCTLS;
- PVariant(VarResult)^ := dlc
- end;
- else
- result := ort
- end
- end
- end;
- procedure TExWebBrowser.Loaded;
- begin
- inherited;
- if not (csDesigning in ComponentState) then
- if fURL = '' then
- Navigate ('about:blank')
- else
- Navigate (fURL);
- end;
- procedure TExWebBrowser.LoadFromStream(s: TStream; takeOwnership: boolean);
- var
- ownership : TStreamOwnership;
- persistStreamInit : IPersistStreamInit;
- adapter : TStreamAdapter;
- begin
- if Document = Nil then
- Navigate ('about:blank');
- if Supports (Document, IPersistStreamInit, persistStreamInit) then
- begin
- if takeOwnership then
- ownership := soOwned
- else
- ownership := soReference;
- adapter := TStreamAdapter.Create(s, ownership);
- OleCheck (persistStreamInit.InitNew);
- OleCheck (persistStreamInit.Load(adapter))
- end
- end;
- procedure TExWebBrowser.LoadFromString(const st: string);
- begin
- LoadFromStream (TStringStream.Create(st), True);
- end;
- function TExWebBrowser.OnDocWindowActivate(const fActivate: BOOL): HRESULT;
- begin
- result := S_OK;
- end;
- function TExWebBrowser.OnFrameWindowActivate(
- const fActivate: BOOL): HRESULT;
- begin
- result := S_OK;
- end;
- function TExWebBrowser.ResizeBorder(const prcBorder: PRECT;
- const pUIWindow: IOleInPlaceUIWindow; const fRameWindow: BOOL): HRESULT;
- begin
- result := S_OK;
- end;
- procedure TExWebBrowser.SetURL(const Value: string);
- begin
- fURL := Value;
- if (csLoading in ComponentState) or (csDesigning in ComponentState) then
- Exit;
- if Value = '' then
- Navigate ('about:blank')
- else
- Navigate (value);
- end;
- function TExWebBrowser.ShowContextMenu(const dwID: DWORD;
- const ppt: PPOINT; const pcmdtReserved: IInterface;
- const pdispReserved: IDispatch): HRESULT;
- begin
- if UIProperties.EnableContextMenu then
- result := S_FALSE
- else
- begin
- result := S_OK;
- if Assigned (PopupMenu) then
- PopupMenu.Popup(ppt.X, ppt.Y)
- end;
- end;
- function TExWebBrowser.ShowUI(const dwID: DWORD;
- const pActiveObject: IOleInPlaceActiveObject;
- const pCommandTarget: IOleCommandTarget; const pFrame: IOleInPlaceFrame;
- const pDoc: IOleInPlaceUIWindow): HRESULT;
- begin
- result := S_FALSE; // IE will display the UI
- end;
- function TExWebBrowser.TranslateAccelerator(const lpMsg: PMSG;
- const pguidCmdGroup: PGUID; const nCmdID: DWORD): HRESULT;
- begin
- result := S_FALSE;
- end;
- function TExWebBrowser.TranslateUrl(const dwTranslate: DWORD;
- const pchURLIn: POLESTR; var ppchURLOut: POLESTR): HRESULT;
- begin
- result := S_FALSE; // URL was not translated
- end;
- function TExWebBrowser.UpdateUI: HRESULT;
- begin
- result := S_FALSE;
- end;
- { TUIProperties }
- constructor TUIProperties.Create(AOwner: TExWebBrowser);
- begin
- fOwner := AOwner;
- fShowImages := True;
- fShowActiveX := True;
- end;
- end.
http://blog.csdn.net/missmecn/article/details/2292758
Delphi 中TWebBrowser的扩展控件TExWebBrowser的更多相关文章
- Delphi中解析Xml的控件-SimDesign NativeXml
Delphi中解析Xml的控件-SimDesign NativeXml 正在学习,感觉应用很方便.无源代码的版本还是免费的. SimDesign.NativeXml是一个delphi和bcb的XML控 ...
- 对delphi中的数据敏感控件的一点探索
一直对delphi数据敏感控件很好奇,感觉很神奇.只要简单设置一下,就显示和编辑数据,不用写一行代码. 如果不用数据敏感控件,编辑一个表字段数据并保存,我相信应用如下代码. Table1.edit, ...
- delphi中使用MSWINSCK.OCX控件
1.首先是把winsck控件导入到delphi中,就是导入一个ActiveX控件,步骤略过. 2.将导入的winsck控件拖入你的Form中. 3.对winsck进行基本设置(IP,Port). 4. ...
- 多年前写的文本框扩展控件(有ValueChanging事件等),已放github
本文版权归mephisto和博客园共有,欢迎转载,但须保留此段声明,并给出原文链接,谢谢合作. 文章是哥(mephisto)写的,SourceLink 阅读目录 介绍 起因 代码 使用 GitHub ...
- Delphi下使用Oracle Access控件组下TOraSession控件链接
Delphi下使用Oracle Access控件组下TOraSession控件链接数据库,使用 orsn1.Options.Direct:=true; orsn1.Server:=IP:Port: ...
- 在Winform开发框架中,利用DevExpress控件实现数据的快速录入和选择
在实际的项目开发过程中,有好的控件或者功能模块,我都是想办法尽可能集成到我的WInform开发框架中,这样后面开发项目起来,就可以节省很多研究时间,并能重复使用,非常高效方便.在我很早之前的一篇博客& ...
- JavaFX的扩展控件库ControlsFX介绍
声明: 本博客文章原创类别的均为个人原创,版权所有.转载请注明出处: http://blog.csdn.net/ml3947,另外本人的个人博客:http://www.wjfxgame.com. ...
- WPF自定义控件(三)の扩展控件
扩展控件,顾名思义就是对已有的控件进行扩展,一般继承于已有的原生控件,不排除继承于自定义的控件,不过这样做意义不大,因为既然都自定义了,为什么不一步到位呢,有些不同的需求也可以通过此来完成,不过类似于 ...
- Delphi 10 Seattle 小票打印控件TQ_Printer
TQ_Printrer控件,是一个为方便需要控制打印命令而设计的跨平台专用控件,已包含标准ESC/POS打印控制的基本指令在内(这些基本指令已能很好的满足多数项目使用). TQ_Printrer控件让 ...
随机推荐
- java--join方法
package MyTest; class TestDemo implements Runnable { public void run() { int i = 0; for (int j = 0; ...
- duilib之源码分析
<duilib之源码分析>1 stdAfx.h * lengthof(x) 计算数组长度宏 * MAX 两值最大 * MIN 两值最小 * CLAMP(x,a,b) x在a,b之间则取 ...
- 浅谈MySql的存储引擎(表类型) (转)
什么是MySql数据库 通常意义上,数据库也就是数据的集合,具体到计算机上数据库可以是存储器上一些文件的集合或者一些内存数据的集合. 我们通常说的MySql数据库,sql server数据库等等其实是 ...
- 重探 DFT
感觉上次学习DFT简直是乱来了.不知道误导了多少人,这里深感抱歉. 这次我再看了看<算法导论>,觉得收获很大,终于粗略的知道DFT的原理了! 如何将两个多项式相乘 对于一个n次多项式,\( ...
- Struts2 学习笔记17 I18N国际化
讲解一下国际化的内容,比如书有些大的网站可以一键切换语言,例如中英切换,这时候就会用到国际化.但是由于struts2大多数是用来写后台,国际化并不是十分重要,而且用国际化开发会减慢开发的速度,大家只要 ...
- UPC 2959: Caoshen like math 这就是个水题
http://acm.upc.edu.cn/problem.php?id=2959 这就是个水题,之所以要写这个题是感觉很有纪念意义 用力看就是盲……23333333333333333 这个题就是最小 ...
- 在Ubuntu下编译Assimp库
在Ubuntu下编译Assimp库 怎样在Ubuntu下编译Assimp库?这是我曾经编译成功后做的笔记,供參考. 1.去以下的站点去下载Assimp库: http://assimp.sourcefo ...
- Swift - 正则表达式的使用(附用户名、邮箱、URL等常用格式验证)
Swift虽然是一个新出的语言,但却不提供专门的处理正则的语法和类.所以我们只能使用古老的NSRegularExpression类进行正则匹配. 即先接受一个正则表达式的字符串,由此生成NSRegul ...
- HDU--杭电--3790--最短路径问题
最短路径问题 Time Limit: 2000/1000 MS (Java/Others) Memory Limit: 32768/32768 K (Java/Others) Total Sub ...
- WEB应用如何解决安全退出问题
让我先来描述一下这个情况.一位用户第一次请求一个web页面,web应用弹出登录窗口提示用户登录,用户输入用户名,密码,验证码后服务器进行判断,正确后,返回用户请求的页面. 此时,用户有事需要离 ...