ietoolbar.txt

往IE中嵌入自己的工具条 往IE中嵌入自己的工具条

往IE中嵌入自己的工具条
版权所有 codesky.net 2003-2005
发表时间：2003-9-16    关键字：不详

我们首先要建立一个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工具栏中