Delphi开发IE中添加工具栏

最新推荐文章于 2020-12-16 07:59:31 发布
最新推荐文章于 2020-12-16 07:59:31 发布
阅读量668 收藏
点赞数
分类专栏： web编程 文章标签： 浏览器 internet

我们首先要建立一个ActiveX Library。将其保存为MailIEBand.Dpr；然后建立一个COM Object，将其保存为BandUnit.pas；然后建立一个Form，这个窗口将作为子窗口显示在IE工具栏中，将窗口的BorderStyle属性改为bsNone，添加一个TButton组件和一个TComboBox组件，将TButton的Caption属性改为获取全部，然后将窗口文件其保存为IEForm.pas。

在BandUnit中，需要建立一个实现上面提到的接口的TComObject对象。如下：

TGetMailBand = class(TComObject, IDeskBand, IObjectWithSite, IPersistStreamInit)


另外由于需要在COM服务器注册时添加一些注册表信息，所以还需要建立一个继承自TComObjectFactory类的对象，在对象的UpdateRegistry事件中编写代码添加附加的注册表信息。

下面的程序清单1-6到1-8是实现COM服务器的全部程序代码：


程序清单1-6 MailIEBand.dpr

library MailIEBand; 
 
 
uses 
 
 ComServ, 
 
 BandUnit  in   ' BandUnit.pas ' , 
 
 IEForm  in   ' IEForm.pas '   {Form1} , 
 
 MailIEBand_TLB  in   ' MailIEBand_TLB.pas ' ; 
 
 
exports 
 
 DllGetClassObject, 
 
 DllCanUnloadNow, 
 
 DllRegisterServer, 
 
 DllUnregisterServer; 
 
 
 {$R *.TLB}  
 
 
 {$R *.RES}  
 
 
begin 
 
end. 
 
 
程序清单1 - 7  BandUnit.pas 
 
 
unit BandUnit; 
 
 
 interface  
 
 
uses 
 
 Windows, Sysutils, Messages, Registry, Shellapi, ActiveX, Classes, ComObj, 
 
  Shlobj, Dialogs, Commctrl,ShDocVW,IEForm; 
 
 
type 
 
 TGetMailBand  =   class (TComObject, IDeskBand, IObjectWithSite, IPersistStreamInit) 
 
  private  
 
   frmIE:TForm1; 
 
   m_pSite:IInputObjectSite; 
 
  m_hwndParent:HWND; 
 
  m_hWnd:HWND; 
 
  m_dwViewMode:Integer; 
 
   m_dwBandID:Integer; 
 
   protected  
 
 
   public  
 
   {Declare IDeskBand methods here}  
 
   function GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo): 
 
     HResult; stdcall; 
 
   function ShowDW(fShow: BOOL): HResult; stdcall; 
 
   function CloseDW(dwReserved: DWORD): HResult; stdcall; 
 
   function ResizeBorderDW(var prcBorder: TRect; punkToolbarSite: IUnknown; 
 
     fReserved: BOOL): HResult; stdcall; 
 
   function GetWindow( out  wnd: HWnd): HResult; stdcall; 
 
   function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; 
 
 
    {Declare IObjectWithSite methods here}  
 
   function SetSite( const  pUnkSite: IUnknown ):HResult; stdcall; 
 
   function GetSite( const  riid: TIID;  out  site: IUnknown):HResult;stdcall; 
 
 
    {Declare IPersistStream methods here}  
 
   function GetClassID( out  classID: TCLSID): HResult; stdcall; 
 
   function IsDirty: HResult; stdcall; 
 
   function InitNew: 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; 
 
 
 const  
 
 Class_GetMailBand: TGUID  =   ' {954F618B-0DEC-4D1A-9317-E0FC96F87865} ' ; 
 
  // 以下是系统接口的IID  
  
 IID_IUnknown: TGUID  =  ( 
 
   D1:$ 00000000 ;D2:$ 0000 ;D3:$ 0000 ;D4:($C0,$ 00 ,$ 00 ,$ 00 ,$ 00 ,$ 00 ,$ 00 ,$ 46 )); 
 
 IID_IOleObject: TGUID  =  ( 
 
   D1:$ 00000112 ;D2:$ 0000 ;D3:$ 0000 ;D4:($C0,$ 00 ,$ 00 ,$ 00 ,$ 00 ,$ 00 ,$ 00 ,$ 46 )); 
 
 IID_IOleWindow: TGUID  =  ( 
 
   D1:$ 00000114 ;D2:$ 0000 ;D3:$ 0000 ;D4:($C0,$ 00 ,$ 00 ,$ 00 ,$ 00 ,$ 00 ,$ 00 ,$ 46 )); 
 
 
 IID_IInputObjectSite : TGUID  =  ( 
 
   D1:$f1db8392;D2:$ 7331 ;D3:$11d0;D4:($8C,$ 99 ,$ 00 ,$A0,$C9,$2D,$BF,$E8)); 
 
 sSID_SInternetExplorer : TGUID  =   ' {0002DF05-0000-0000-C000-000000000046} ' ; 
 
 sIID_IWebBrowserApp : TGUID =   ' {0002DF05-0000-0000-C000-000000000046} ' ; 
 
 
  // 面板所允许的最小宽度和高度。  
  
 MIN_SIZE_X  =   54 ; 
 
 MIN_SIZE_Y  =   22 ; 
 
 EB_CLASS_NAME  =   ' GetMailAddress ' ; 
 
implementation 
 
 
uses ComServ; 
 
 
 
function TGetMailBand.GetWindow( out  wnd: HWnd): HResult; stdcall; 
 
begin 
 
  wnd: = m_hWnd; 
 
  Result: = S_OK; 
 
end; 
 
 
function TGetMailBand.ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; 
 
begin 
 
  Result: = E_NOTIMPL; 
 
end; 
 
 
function TGetMailBand.ShowDW(fShow: BOOL): HResult; stdcall; 
 
begin 
 
   if  m_hWnd <> 0  then 
 
    if  fShow then 
 
     ShowWindow(m_hWnd,SW_SHOW) 
 
    else  
 
     ShowWindow(m_hWnd,SW_HIDE); 
 
  Result: = S_OK; 
 
end; 
 
 
function TGetMailBand.CloseDW(dwReserved: DWORD): HResult; stdcall; 
 
begin 
 
   if  frmIE <> nil then 
 
   frmIE.Destroy; 
 
  Result: =  S_OK; 
 
end; 
 
 
function TGetMailBand.ResizeBorderDW(var prcBorder: TRect; 
 
   punkToolbarSite: IUnknown;fReserved: BOOL): HResult; stdcall; 
 
begin 
 
  Result: = E_NOTIMPL; 
 
end; 
 
 
function TGetMailBand.SetSite( const  pUnkSite: IUnknown):HResult;stdcall; 
 
var 
 
  pOleWindow:IOleWindow; 
 
  pOLEcmd:IOleCommandTarget; 
 
  pSP:IServiceProvider; 
 
  rc:TRect; 
 
begin 
 
   if  Assigned(pUnkSite) then begin 
 
   m_hwndParent : =   0 ; 
 
 
   m_pSite: = pUnkSite  as  IInputObjectSite; 
 
   pOleWindow : =  PunkSIte  as  IOleWindow; 
 
    // 获得父窗口IE面板窗口的句柄  
  
   pOleWindow.GetWindow(m_hwndParent); 
 
 
    if (m_hwndParent = 0 )then begin 
 
     Result : =  E_FAIL; 
 
     exit; 
 
   end; 
 
 
    // 获得父窗口区域  
  
   GetClientRect(m_hwndParent, rc); 
 
 
    if  not Assigned(frmIE) then begin 
 
      // 建立TIEForm窗口，父窗口为m_hwndParent  
  
     frmIE: = TForm1.CreateParented(m_hwndParent); 
 
 
     m_Hwnd: = frmIE.Handle; 
 
 
     SetWindowLong(frmIE.Handle, GWL_STYLE, GetWindowLong(frmIE.Handle, 
 
      GWL_STYLE) Or WS_CHILD); 
 
      // 根据父窗口区域设置窗口位置  
  
     with frmIE  do  begin 
 
      Left : = rc.Left ; 
 
      Top: = rc.top; 
 
      Width: = rc.Right  -  rc.Left; 
 
      Height: = rc.Bottom  -  rc.Top; 
 
     end; 
 
     frmIE.Visible : =  True; 
 
 
      // 获得与浏览器相关联的Webbrowser对象。  
  
     pOLEcmd: = pUnkSite  as  IOleCommandTarget; 
 
     pSP: = pOLEcmd  as  IServiceProvider; 
 
 
      if  Assigned(pSP)then begin 
 
      pSP.QueryService(IWebbrowserApp, IWebbrowser2,frmIE.IEThis); 
 
     end; 
 
   end; 
 
  end; 
 
 
  Result : =  S_OK; 
 
end; 
 
 
function TGetMailBand.GetSite( const  riid: TIID;  out  site: IUnknown):HResult;stdcall; 
 
begin 
 
   if  Assigned(m_pSite) then result: = m_pSite.QueryInterface(riid, site) 
 
   else  
 
   Result: =  E_FAIL; 
 
end; 
 
 
function TGetMailBand.GetBandInfo(dwBandID, dwViewMode: DWORD; var pdbi: TDeskBandInfo): 
 
   HResult; stdcall; 
 
begin 
 
  Result: = E_INVALIDARG; 
 
   if  not Assigned(frmIE) then frmIE: = TForm1.CreateParented(m_hwndParent); 
 
   if (@pdbi <> nil)then begin 
 
   m_dwBandID : =  dwBandID; 
 
   m_dwViewMode : =  dwViewMode; 
 
 
    if (pdbi.dwMask and DBIM_MINSIZE) <> 0  then begin 
 
     pdbi.ptMinSize.x : =  MIN_SIZE_X; 
 
     pdbi.ptMinSize.y : =  MIN_SIZE_Y; 
 
   end; 
 
 
    if (pdbi.dwMask and DBIM_MAXSIZE) <> 0  then begin 
 
     pdbi.ptMaxSize.x : =   - 1 ; 
 
     pdbi.ptMaxSize.y : =   - 1 ; 
 
   end; 
 
 
    if (pdbi.dwMask and DBIM_INTEGRAL) <> 0  then begin 
 
     pdbi.ptIntegral.x : =   1 ; 
 
     pdbi.ptIntegral.y : =   1 ; 
 
   end; 
 
 
    if (pdbi.dwMask and DBIM_ACTUAL) <> 0  then begin 
 
     pdbi.ptActual.x : =   0 ; 
 
     pdbi.ptActual.y : =   0 ; 
 
   end; 
 
 
    if (pdbi.dwMask and DBIM_MODEFLAGS) <> 0  then 
 
     pdbi.dwModeFlags : =  DBIMF_VARIABLEHEIGHT; 
 
 
    if (pdbi.dwMask and DBIM_BKCOLOR) <> 0  then 
 
     pdbi.dwMask : =  pdbi.dwMask and (not DBIM_BKCOLOR); 
 
  end; 
 
end; 
 
 
 
function TGetMailBand.GetClassID( out  classID: TCLSID): HResult; stdcall; 
 
begin 
 
  classID: =  Class_GetMailBand; 
 
  Result: = S_OK; 
 
end; 
 
 
function TGetMailBand.IsDirty: HResult; stdcall; 
 
begin 
 
  Result: = S_FALSE; 
 
end; 
 
 
function TGetMailBand.InitNew: HResult; 
 
begin 
 
 Result : =  E_NOTIMPL; 
 
end; 
 
 
function TGetMailBand.Load( const  stm: IStream): HResult; stdcall; 
 
begin 
 
  Result: = S_OK; 
 
end; 
 
 
function TGetMailBand.Save( const  stm: IStream; fClearDirty: BOOL): HResult; stdcall; 
 
begin 
 
  Result: = S_OK; 
 
end; 
 
 
function TGetMailBand.GetSizeMax( out  cbSize: Largeint): HResult; stdcall; 
 
begin 
 
  Result: = E_NOTIMPL; 
 
end; 
 
 
 
 // TIEClassFac类实现COM组件的注册  
  
type 
 
  TIEClassFac = class (TComObjectFactory)  // 
  
   public  
 
   procedure UpdateRegistry(Register: Boolean);  override ; 
 
  end; 
 
 
procedure TIEClassFac.UpdateRegistry(Register: Boolean); 
 
var 
 
 ClassID:  string ; 
 
 a:Integer; 
 
begin 
 
  inherited UpdateRegistry(Register); 
 
   if  Register then begin 
 
   ClassID: = GUIDToString(Class_GetMailBand); 
 
   with TRegistry.Create  do  
 
     try  
 
      // 添加附加的注册表项  
  
     RootKey: = HKEY_LOCAL_MACHINE; 
 
     OpenKey( ' \SOFTWARE\Microsoft\Internet Explorer\Toolbar ' ,False); 
 
     a: = 0 ; 
 
     WriteBinaryData(GUIDToString(Class_GetMailBand),a, 0 ); 
 
     OpenKey( ' \SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved ' ,True); 
 
     WriteString (GUIDToString(Class_GetMailBand),EB_CLASS_NAME); 
 
     RootKey: = HKEY_CLASSES_ROOT; 
 
     OpenKey( ' \CLSID\ ' + GUIDToString(Class_GetMailBand),False); 
 
     WriteString( '' ,EB_CLASS_NAME); 
 
     finally  
 
     Free; 
 
    end; 
 
  end 
 
   else  begin 
 
   with TRegistry.Create  do  
 
    try  
 
     RootKey: = HKEY_LOCAL_MACHINE; 
 
     OpenKey( ' \SOFTWARE\Microsoft\Internet Explorer\Toolbar ' ,False); 
 
     DeleteValue(GUIDToString(Class_GetMailBand)); 
 
     OpenKey( ' \Software\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved ' ,False); 
 
     DeleteValue(GUIDToString(Class_GetMailBand)); 
 
    finally  
 
     Free; 
 
   end; 
 
  end; 
 
end; 
 
 
initialization 
 
  TIEClassFac.Create(ComServer, TGetMailBand, Class_GetMailBand, 
 
    ' GetMailAddress ' ,  '' , ciMultiInstance, tmApartment); 
 
end. 
 
 
程序清单1 - 8  IEForm.pas 
 
 
unit IEForm; 
 
 
 interface  
 
 
uses 
 
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
 
 SHDocVw,MSHTML, StdCtrls; 
 
 
type 
 
 TForm1  =   class (TForm) 
 
  Button1: TButton; 
 
  ComboBox1: TComboBox; 
 
  procedure FormResize(Sender: TObject); 
 
  procedure Button1Click(Sender: TObject); 
 
  private  
 
   { Private declarations }  
 
  public  
 
  IEThis:IWebbrowser2; 
 
   { Public declarations }  
 
 end; 
 
 
var 
 
 Form1: TForm1; 
 
 
implementation 
 
 
 {$R *.DFM}  
 
 
procedure TForm1.FormResize(Sender: TObject); 
 
begin 
 
 With Button1  do  begin 
 
  Left : =   0 ; 
 
  Top : =   0 ; 
 
  Height: = Self.ClientHeight; 
 
 end; 
 
 With ComboBox1  do  begin 
 
  Left : =  Button1.Width  + 3 ; 
 
  Top : =   0 ; 
 
  Height: = Self.ClientHeight; 
 
  Width: = Self.ClientWidth  -  Left; 
 
 end; 
 
end; 
 
 
procedure TForm1.Button1Click(Sender: TObject); 
 
var 
 
 doc:IHTMLDocument2; 
 
 all:IHTMLElementCollection; 
 
 len,i,flag:integer; 
 
 item:IHTMLElement; 
 
 vAttri:Variant; 
 
begin 
 
  if  Assigned(IEThis)then begin 
 
  ComboBox1.Clear; 
 
   // 获得Webbrowser对象中的文档对象  
  
  doc: = IEThis.Document  as  IHTMLDocument2; 
 
   // 获得文档中所有的HTML元素集合  
  
  all: = doc.Get_all; 
 
 
  len: = all.Get_length; 
 
 
   // 访问HTML元素集合中的每一个元素  
  
   for  i: = 0  to len - 1   do  begin 
 
   item: = all.item(i,varempty)  as  IHTMLElement; 
 
    // 如果该元素是一个链接  
  
    if  item.Get_tagName  =   ' A ' then begin 
 
    flag: = 0 ; 
 
    vAttri: = item.getAttribute( ' protocol ' ,flag);    // 获得链接属性 
 
     // 如果是mailto链接则将链接的目标地址添加到ComboBox1  
  
     if  vAttri  =   ' mailto: ' then begin 
 
     vAttri: = item.getAttribute( ' href ' ,flag); 
 
     ComboBox1.Items.Add(vAttri); 
 
    end; 
 
   end; 
 
  end; 
 
 end; 
 
end; 
 
 
end. 
编译工程，关闭所有的IE窗口，然后点击Delphi菜单的Run | Register ActiveX Server 项注册服务器。然后打开IE，点击菜单 察看 | 工具栏 项，可以看到子菜单中多了一个GetMailAddress项，选中改项，工具栏就出现在IE工具栏中 
chinajobs
关注
  • 0
    点赞
  • 踩
  • 0
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
专栏目录
IE.rar_IE_IE toolbar_IE 工具_IE工具栏_delphi ie工具栏
09-19
总的来说，这个压缩包为想要使用Delphi开发Internet Explorer工具栏的开发者提供了一个实例，他们可以从中学到如何设计和实现自定义的浏览器界面元素，增强用户在IE浏览器上的交互体验。通过解压文件、阅读文档和源...
delphi读写跨域页面文本域（IE6）
t1122的专栏
04-20 1449
（转自：http://hi.baidu.com/xiaoqing2305/blog/item/6a64398103472ef8bd3e1e2d.html） 在程序开发中遇到跨域访问提示“拒绝访问”，过网上查找，自己实际测试写出得方法能够实现写文本域，但是个人感觉很麻烦，不知道是 不是最佳办法，写出来分享一下，如果有好的处理方法请大家多多指正！ HTML页面代码如下： 1、主页面main.
免费沙箱软件模拟支付_CVE20193969：Comodo沙箱逃逸提权漏洞分析
weixin_28323057的博客
12-16 458
译文声明本文是翻译文章，文章原作者tenable-techblog，文章来源：medium.com原文地址：https://medium.com/tenable-techblog/comodo-from-sandbox-to-system-cve-2019-3969-b6a34cc85e67译文仅供参考，具体内容表达以及含义原文为准0x00 前言AV(反病毒软件)一直以来都是漏洞挖掘的绝...
delphi制作类似ie的工具栏
10-23
在Delphi中制作类似Internet Explorer（IE）的工具栏是一个常见的需求，这涉及到用户界面（UI）设计和组件编程。Delphi作为一个强大的Windows应用程序开发工具，提供了丰富的组件库，使得这个任务变得相对简单。以下...
300 向IE的工具栏中添加按钮.rar
08-14
本资源“300 向IE的工具栏中添加按钮.rar”显然是一个关于如何使用Delphi编程语言来实现这一功能的教程或代码示例集合。Delphi是一款强大的Windows应用程序开发工具，以其高效的Object Pascal编程语言和Visual ...
delphi开发的 BHO ie插件
05-17
BHO 通常用于添加浏览器功能，如广告拦截、网页增强、工具栏等。 3. **文件解析：** - `IEHelper.cfg`：可能是一个配置文件，用于存储插件的设置或参数。 - `IEHelperUnit.dcu`：Delphi 的编译单元文件，包含了已...
ie_toolbar.zip_IE toolbar_delphi toolbar
最新发布
09-23
5. **事件处理**：Delphi中的事件驱动编程模型使得能够轻松地为工具栏上的各个元素添加响应代码，例如单击按钮时执行特定的操作。 6. **注册和卸载**：安装工具栏需要注册COM组件到系统注册表中，以便IE能够识别和...
delphi 实现多个浮动透明窗口
03-01
delphi 实现多个浮动透明窗口，多个窗口相互独立，可以自由拉动，模拟迅雷浮动窗口。程序启动时显示主窗口，关闭时显示5个浮动透明窗口
ExplorerBar组件
12-22
仿win7资源浏览器左侧的卡片式显示组件。美观好用，支持D7以上的版本。
给Delphi的工具条按钮添加BTNS_WHOLEDROPDOWN风格
wr960204(武稀松)的专栏
12-17 3743
<br />工具条按钮的BTNS_WHOLEDROPDOWN风格是IE5以后就提供的.<br />Delphi早期版本估计是为了照顾兼容性工具条按钮是没有这个风格的.只有下面几种和系统风格对应的风格.<br />  TToolButtonStyle = (tbsButton, tbsCheck, tbsDropDown, tbsSeparator,<br />     tbsDivider, tbsTextButton);<br />后面尽管IE5以下根本没人用了,但是Delphi的开发人员都忘了添加一种
往IE中嵌入工具条
虫二的专栏~~在路上~~~
08-28 1509
 我们首先要建立一个ActiveX Library。将其保存为MailIEBand.Dpr；然后建立一个COM Object，将其保存为BandUnit.pas；然后建立一个Form，这个窗口将作为子窗口显示在IE工具栏中，将窗口的BorderStyle属性改为bsNone，添加一个TButton组件和一个TComboBox组件，将TButton的Caption属性改为获取全部，然后将窗口文件
Delphi 悬浮窗口、浮动窗口的实现
weixin_34018202的博客
11-09 1935
源：Delphi 悬浮窗口、浮动窗口的实现   浮动窗体的实现 http://blog.tianya.cn/blogger/post_show.asp?BlogID=68097&amp;PostID=806089需要一个这样的窗体:a:没有标题栏; b:可以改变大小; c:不在任务栏上显示图标; d:如果不是主窗体,它的最小化不受主窗体的限制; e:在最顶端显示处理:a:不在任务栏出现的,只要...
Delphi7中IntraWeb应用开发全面解析
"Delphi7下IntraWeb应用开发详解" 本资料详细介绍了在Delphi7环境下使用IntraWeb进行Web应用开发的技术和实践。IntraWeb是一个强大的框架，允许开发者使用Delphi的VCL组件来创建服务器端的Web应用程序，从而实现...
评论
添加红包

请填写红包祝福语或标题

个

红包个数最小为10个

元

红包金额最低5元

当前余额3.43元 前往充值 >
需支付：10.00元
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付元
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明：

1.余额是钱包充值的虚拟货币，按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载，可以购买VIP、付费专栏及课程。

余额充值