高分求类似新浪工具条一样的‘IE TOOLBAR’编写及注册方法。(300分)

看了E文的MSDN和IEDELPHI，还是解决不了问题（E文水平太差）。而且IEDELPHI中的例子也不是完全解
决方案，编译后只生成了一个DLL文件。

所以急求各位老大帮助。
有具体的源代码
最好是提供解决的方法说明并对部分难点做一些说明。

unit AddBt2IE;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ComCtrls,shellapi, Buttons,Registry;
type
TForm1 = class(TForm)
OpenDialog1: TOpenDialog;
OpenDialog2: TOpenDialog;
GroupBox2: TGroupBox;
Label6: TLabel;
Label7: TLabel;
Label8: TLabel;
Label9: TLabel;
Echxu: TEdit;
Button1: TButton;
Ewenzi: TEdit;
Etubiao1: TEdit;
Button2: TButton;
Etubiao2: TEdit;
Button3: TButton;
Button4: TButton;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
procedure BitBtn2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn1MouseDown(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
procedure BitBtn1MouseUp(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
procedure BitBtn2MouseDown(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
procedure BitBtn2MouseUp(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
procedure Button1MouseDown(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
procedure Button1MouseUp(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
procedure FormCreate(Sender: TObject);
procedure Label4Click(Sender: TObject);
procedure FormMouseMove(Sender: TObject
Shift: TShiftState
X,
Y: Integer);
procedure BitBtn1MouseMove(Sender: TObject
Shift: TShiftState
X,
Y: Integer);
procedure BitBtn2MouseMove(Sender: TObject
Shift: TShiftState
X,
Y: Integer);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.BitBtn2Click(Sender: TObject);
begin
Application.Terminate;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if OpenDialog1.execute
then
Echxu.text:=openDialog1.filename
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
if OpenDialog2.execute
then
Etubiao1.text:=openDialog2.filename
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
if OpenDialog2.execute
then
Etubiao2.text:=openDialog2.filename
end;

procedure TForm1.BitBtn1Click(Sender: TObject);
var
rg:Tregistry;
begin
rg:=Tregistry.create;
rg.rootkey:=HKEY_LOCAL_MACHINE;
rg.openkey('SOFTWARE/MICROSOFT/INTERNET EXPLORER/EXTENSIONS/{0713E8D2-850A-101B-AFC0-4210102A8DA7}',true);

rg.writestring('BUTTONTEXT',Ewenzi.text);
rg.writestring('CLSID','{1FBA04EE-3024-11D2-8F1F-0000F87ABD16}');
rg.writestring('DEFAULT VISIBLE','YES');
rg.writestring('EXEC',Echxu.text);
rg.writestring('ICON',Etubiao1.text);
rg.writestring('HOTICON',Etubiao2.text);

rg.closekey;
rg.free;
end;

procedure TForm1.BitBtn1MouseDown(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
begin

if BitBtn1.font.color=clgreen
then
BitBtn1.font.color:=clred;

end;

procedure TForm1.BitBtn1MouseUp(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
begin
BitBtn1.font.color:=clgreen
end;

procedure TForm1.BitBtn2MouseDown(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
begin
BitBtn2.font.color:=clred;
end;

procedure TForm1.BitBtn2MouseUp(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
begin
BitBtn2.font.color:=clgreen;
end;

procedure TForm1.Button1MouseDown(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
begin
Button1.font.color:=clred;
end;

procedure TForm1.Button1MouseUp(Sender: TObject
Button: TMouseButton;
Shift: TShiftState
X, Y: Integer);
begin
Button1.font.color:=clgreen;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
Application.hintcolor:=clyellow;
Application.hintpause:=0;
end;

procedure TForm1.Label4Click(Sender: TObject);
begin
ShellExecute(handle,nil,pchar('mailto:yukaikai@263.net'),nil,nil,sw_shownormal);
end;

procedure TForm1.FormMouseMove(Sender: TObject
Shift: TShiftState
X,
Y: Integer);
begin
Bitbtn1.Font.color:=clgreen;
Bitbtn2.Font.color:=clgreen;

end;

procedure TForm1.BitBtn1MouseMove(Sender: TObject
Shift: TShiftState
X,
Y: Integer);
begin
BitBtn1.font.color:=clblue;
end;

procedure TForm1.BitBtn2MouseMove(Sender: TObject
Shift: TShiftState
X,
Y: Integer);
begin
BitBtn2.font.color:=clblue;
end;

end.

To forgot2002:
能不能给点注释？
或者说明？
感觉你的代码是添加标准按纽的，不是添加一个像“新浪工具条”或者“FlashGet Bar”
那样的工具条。
还有
rg.openkey('SOFTWARE/MICROSOFT/INTERNET EXPLORER/EXTENSIONS/{0713E8D2-850A-101B-AFC0-4210102A8DA7}',true);
中的{0713E8D2-850A-101B-AFC0-4210102A8DA7}怎么来的？
为什么可以确认以前没有呢？

补充：
我所说的功能就像http://www.euromind.com/iedelphi/ie5tools/bandobjects.htm中所提的。

你看看注册表中是不是有这个功能的键值啊，这是个好的功能，说不定研究了还可以写出
来赚点稿费呢[]

往IE中嵌入工具条

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


www.applevb.com

To wolfsong
我试试。
请问那个网站是你的吗？做的非常好哟，以前我去看过的。不过好象没什么DELPHI。
你是搞软件+网站的“双抢手”吗？哈哈哈，我对网站方面也是有所涉猎。有机会可
以交流。
Mail:HeZhiQun@ynto.net
QQ:78925128

应该是没有问题的，

呵呵，不是我的站：-）
不过我以前是做互联网开发的。
我已经加了你的q