子
子弹
Unregistered / Unconfirmed
GUEST, unregistred user!
up,好象改注册表就可以了。
N
netwinds
Unregistered / Unconfirmed
GUEST, unregistred user!
怎么改，能不能不用好象？？？
再请高手！！！！！！
再请高手！！！！！！
子
子弹
Unregistered / Unconfirmed
GUEST, unregistred user!
学习。
N
ndch
Unregistered / Unconfirmed
GUEST, unregistred user!
GZ
L
lfpsoft
Unregistered / Unconfirmed
GUEST, unregistred user!
学习
L
lfpsoft
Unregistered / Unconfirmed
GUEST, unregistred user!
楼主，我想看看第一个问题的源代码，能给我看看吗？
lfpsoft@163.com
谢谢！
lfpsoft@163.com
谢谢！
小
小雨哥
Unregistered / Unconfirmed
GUEST, unregistred user!
问题一：上下文菜单
Windows操作系统具有用户界面的可扩充性。可以通过多种方式来增强系统的外壳。通过对外壳的扩展，
开发人员可以为用户提供其他的文件对象操作方式或者简化文件系统和网络的浏览，或者使用户能更方便地调用
文件系统中对各种对象进行处理的工具。例如，给一些特殊的文件夹赋予与众不同的图标、可以向外壳对象上下
文相关菜单动态地添加命令等等。这都是依靠Windows外壳扩展(Shell Extensions)。
1．外壳扩展概述
下面是与外壳扩展相关的三个重要术语：
(1)文件对象(File Object)
文件对象是外壳中的一项，大家最熟识的文件对象是文件和目录，此外，打印机、控制面板程序、共享网络
等也都是文件对象。
(2)文件类(File Class)
文件类是具有某种共同特性的文件对象的集合，比如，扩展名相同的文件属于同一文件类。
(3)处理程序(Handler)
处理程序是具体实现某个外壳扩展的代码。
Windows支持七种类型的外壳扩展（称为Handler），它们相应的作用简述如下：
(1)Context menu handlers向特定类型的文件对象增添上下文相关菜单；
(2)Drag-and-drop handlers用来支持当用户对某种类型的文件对象进行拖放操作时的OLE数据传输；
(3)Icon handlers用来向某个文件对象提供一个特有的图标，也可以给某一类文件对象指定图标；
(4)Property sheet handlers给文件对象增添属性页，属性页可以为同一类文件对象所共有，也可以
给一个文件对象指定特有的属性页；
(5)Copy-hook handlers在文件夹对象或者打印机对象被拷贝、移动、删除和重命名时，就会被系统调
用，通过为Windows增加Copy-hook handlers，可以允许或者禁止其中的某些操作；
(6)Drop target handlers在一个对象被拖放到另一个对象上时，就会被系统被调用；
(7)Data object handlers在文件被拖放、拷贝或者粘贴时，就会被系统被调用。
Windows的所有外壳扩展都是基于COM(Component Object Model) 组件模型的，外壳是通过接口
(Interface)来访问对象的。外壳扩展被设计成32位的进程中服务器程序，并且都是以动态链接库的形式为
操作系统提供服务的。因此，如果要对Windows的用户界面进行扩充的话，则具备写COM对象的一些知识是十
分必要的。写好外壳扩展程序后，必须将它们注册才能生效。所有的外壳扩展都必须在注册表的
HKEY_CLASSES_ROOT/CLSID键之下进行注册。
在该键下面可以找到许多名字像{0000002F-0000-0000-C000-000000000046}的键，这类键就是全局
唯一类标识符。每一个外壳扩展都必须有一个全局唯一类标识符，Windows正是通过此唯一类标识符来找到外
壳扩展处理程序的。在类标识符之下的InProcServer32子键下记录着外壳扩展动态链接库在系统中的位置。
与某种文件类型关联的外壳扩展注册在相应类型的shellex主键下。如果所处的Windows操作系统为
Windows NT，则外壳扩展还必须在注册表中的
HKEY_LOCAL_MACHINE/Software/Microsoft/Windows/CurrentVersion/ShellExtensions/App
roved主键下登记。
注册表HKEY_CLASSES_ROOT主键下有几个特殊的子键，如*、Folder、Drive以及Printer。如果把
外壳扩展注册在*子键下，那么这个外壳扩展将对Windows中所有类型的文件有效；如果把外壳扩展注册在
Folder子键下，则对所有目录有效。以下是在*子键下注册的外壳扩展的一个示例（其中登记了一个属性页和
一个WinZip提供的上下文相关菜单处理程序）：
[HKEY_CLASSES_ROOT/*/shellex]
@=""
[HKEY_CLASSES_ROOT/*/shellex/PropertySheetHandlers]
[HKEY_CLASSES_ROOT/*/shellex/PropertySheetHandlers/{3EA48300-8CF6-101B-84FB-666C
CB9BCD32}]
@=""
[HKEY_CLASSES_ROOT/*/shellex/ContextMenuHandlers]
@=""
[HKEY_CLASSES_ROOT/*/shellex/ContextMenuHandlers/WinZip]
@="{E0D79300-84BE-11CE-9641-444553540000}"
注册外壳扩展的DLL程序可以用Windows提供的regsvr32.exe。也可以使用Delphi的Run菜单中的
Register ActiveX Server来注册。
如前所述，Windows的外壳扩展都是基于微软公司的COM组件模型的，从这个意义上来讲，编写外壳扩展
的过程其实就是构造COM对象的过程。但由于各种外壳对象的功能不同，它们要遵循的规则也不同。鉴于
Context Menu Handler这种类型的外壳扩展的应用性比较广，下面以一个实例来具体介绍Context Menu
Handler外壳扩展的实现方法。只要熟练地掌握了其中一种外壳扩展程序的编写方法，在需要编写其他类型的
外壳扩展时再具体查阅一下相应的规则，就可以比较容易地实现其他类型的外壳扩展了。建议读者到微软公司的
网站上去找相关资料，为此先进入http://www.microsoft.com站点，然后单击Search按钮，输入Shell
extension作为关键字，查找范围应选Developer Resources，再按Search按钮即可。
2．上下文相关菜单处理程序的编写
在Windows中，用鼠标右键单击文件或者文件夹时弹出的那个菜单便称为上下文相关菜单。要动态地在上
下文相关菜单中增添菜单项，可以通过写Context Menu Handler来实现。比如大家所熟悉的WinZip和
UltraEdit等软件都是通过编写Context Menu Handler来动态地向菜单中增添菜单项的。如果系统中安
装了WinZip，那么当用右键单击一个名为abc的文件（夹）时，其上下文相关菜单就会有一个名为Add to
abc.zip的菜单项。本文要实现的Context Menu Handler与WinZip提供的上下文菜单相似，它将在任
意类型文件的上下文菜单中增加一个名为“用写字板打开XXX”（其中XXX为当前选定的文件名称）的菜单项，
只要你选择该菜单项，Windows就会启动写字板并打开当前所选的文件
编写Context Menu Handler必须实现IShellExtInit和IContextMenu两个接口。除了IUnknown
接口所定义的函数之外，Context Menu Handler还需要用到QueryContextMenu、InvokeCommand和
GetCommandString这三个非常重要的成员函数。
(1)QueryContextMenu函数：每当系统要显示一个文件对象的上下文相关菜单时，它首先要调用该函数。
为了在上下文相关菜单中添加菜单项，我们在该函数中调用InsertMenu函数。
(2)InvokeCommand函数：当用户选定了某个Context Menu Handler登记过的菜单项后，该函数将
会被调用，系统将会传给该函数一个指向LPCMINVOKECOMMANDINFO结构的指针。在该函数中要执行与所选
菜单项相对应的操作。
(3)GetCommandString函数：当鼠标指针移到一个上下文相关菜单项上时，在当前窗口的状态条上将会
出现与该菜单项相关的帮助信息，此信息就是系统通过调用该函数获取的。
具体编写方法请参阅网上的程序实例，网址为www.pccomputing.com.cn。
3．增添上下文相关菜单项说明
如果要静态地为目录或者某一类文件增添上下文相关菜单项，那么就用不着编写Context Menu Handler，
可以通过直接修改Windows注册表来达到此目的。比如，可以将下面的内容存成一个扩展名为.REG的文件，
然后双击它将其导入注册表，你会发现所有类型文件的上下文相关菜单中都多了一个名叫“记事本”的菜单项。
REGEDIT4
[HKEY_CLASSES_ROOT/*/shell/记事本]
[HKEY_CLASSES_ROOT/*/shell/记事本/command]
@="notepad.exe/"%1/""
通过比较，很容易发现这两种方式所得结果的差异。通过直接修改注册表来增添菜单项的确比较简单，然而
它不具有交互性，所增添的菜单项是静态的，并且所能实现的功能也非常有限。但是Context Menu Handler
则不同，它使我们可以根据上下文的具体情况动态地添加菜单项，比如可以判断当前选定的是哪一类文件、是不
是文件夹、选定的文件（夹）的个数以及获取被选定文件（夹）的属性。有时，这些信息对于程序很有用，如果
需要得到此类信息，并且需要根据不同的上下文来执行不同的操作，那么只好依靠Context Menu Hander来
实现。本例中，其动态性体现在仅当用户选定了一个文件时，才会在上下文相关菜单中增添菜单项，并且菜单项
的名字随着所选文件名的不同而相应地变化。
上下文相关菜单处理程序编写方法的实例。
//Context Menu Handler
//Written Nov 1998 by Ming-Hua LIU
//E-mail: minghua_liu@263.net
unit ContextMenuHandler;
interface
uses Windows,ActiveX,ComObj,ShlObj;
type
TContextMenu = class(TComObject,IShellExtInit,IContextMenu)
private
FFileName: array[0..MAX_PATH] of Char;
protected
{ IShellExtInit }
function IShellExtInit.Initialize = SEIInitialize; // Avoid compiler warning
function SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
hKeyProgID: HKEY): HResult; stdcall;
{ IContextMenu }
function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast,
uFlags: UINT): HResult; stdcall;
function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HResult; stdcall;
end;
const
Class_ContextMenu: TGUID = '{19780513-C829-11D1-8233-0020AF3E97A9}';
{全局唯一标识符(GUID)是一个16字节（128为）的值，它唯一地标识一个接口(interface)}
implementation
uses ComServ, SysUtils, ShellApi, Registry;
function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj:
IDataObject;
hKeyProgID: HKEY): HResult;
var
StgMedium: TStgMedium;
FormatEtc: TFormatEtc;
begin
//如果lpdobj等于Nil，则本调用失败
if (lpdobj = nil) then begin
Result := E_INVALIDARG;
Exit;
end;
with FormatEtc do begin
cfFormat := CF_HDROP;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;
Result := lpdobj.GetData(FormatEtc, StgMedium);
if Failed(Result) then Exit;
{用DragQueryFile函数来查询选定的文件的个数。本例中仅当只选定
一个文件时才在上下文相关菜单中增加菜单项。}
if (DragQueryFile(StgMedium.hGlobal,$FFFFFFFF,nil,0) = 1) then begin
DragQueryFile(StgMedium.hGlobal, 0, FFileName, SizeOf(FFileName));
Result := NOERROR;
end
else begin
FFileName[0] := #0;
Result := E_FAIL;
end;
ReleaseStgMedium(StgMedium);
end;
function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
idCmdLast, uFlags: UINT): HResult;
begin
Result := 0;
if ((uFlags and $0000000F) = CMF_NORMAL) or
((uFlags and CMF_EXPLORE) <> 0) then begin
// 往Context Menu中加入一个菜单项
InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst,
PChar('用写字板打开 '+ExtractFileName(FFileName)));
// 返回增加菜单项的个数
Result := 1;
end;
end;
function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
var
H: THandle; WordpadPath:String; Reg:TRegistry;
begin
// Make sure we are not being called by an application
if (HiWord(Integer(lpici.lpVerb)) <> 0) then
begin
Result := E_FAIL;
Exit;
end;
// Make sure we aren't being passed an invalid argument number
if (LoWord(lpici.lpVerb) <> 0) then begin
Result := E_INVALIDARG;
Exit;
end;
//当用户选定'用写字板打开XXX'时，执行WordPad.exe
//先获取WordPad.exe的路径
Reg:=TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
Reg.OpenKeyReadOnly('SOFTWARE/Microsoft/Windows/CurrentVersion/App
Paths/WORDPAD.EXE');
WordpadPath:=Reg.ReadString('');//注意：两个撇号(')之间无空格
Reg.Free;
H := WinExec(PChar(WordPadPath+' ' +'"'+FfileName+'"'), lpici.nShow);
//注意：最前一对撇号(')之间为空格，后两对撇号中为双引号。
if (H < 32) then
MessageBox(lpici.hWnd, '执行写字板时出错！', '错误', MB_ICONERROR+MB_OK);
Result := NOERROR;
end;
function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HRESULT;
begin
if (idCmd = 0) then begin
if (uType = GCS_HELPTEXT) then
{返回该菜单项的帮助信息，此帮助信息将在用户把鼠标移动到该菜单项时出现在状态条上。}
StrCopy(pszName, PChar('用写字板打开'+FFileName));
Result := NOERROR;
end
else
Result := E_INVALIDARG;
end;
type
TContextMenuFactory = class(TComObjectFactory)
public
procedure UpdateRegistry(Register: Boolean); override;
end;
procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
var
ClassID: string;
begin
if Register then begin
inherited UpdateRegistry(Register);
ClassID := GUIDToString(Class_ContextMenu);
CreateRegKey('*/shellex', '', '');
CreateRegKey('*/shellex/ContextMenuHandlers', '', '');
CreateRegKey('*/shellex/ContextMenuHandlers/OpenWithWordPad', '', ClassID);
//如果操作系统为Windows NT的话
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SOFTWARE/Microsoft/Windows/CurrentVersion/Shell Extensions', True);
OpenKey('Approved', True);
WriteString(ClassID, 'Context Menu Shell Extension');
finally
Free;
end;
end
else begin
DeleteRegKey('*/shellex/ContextMenuHandlers/OpenWithWordPad');
DeleteRegKey('*/shellex/ContextMenuHandlers');
DeleteRegKey('*/shellex');
inherited UpdateRegistry(Register);
end;
end;
initialization
TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
'', 'Context Menu Shell Extension', ciMultiInstance,
tmApartment);
end.
工程文件(*.DPR)的内容如下：
// This COM server defines a Context Menu shell extension.
library ContextMenu;
uses
ComServ,
ContextMenuHandler in 'ContextMenuHandler.pas',
contmenu_TLB in 'contmenu_TLB.pas';
exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;
{$R *.TLB}
{$R *.RES}
begin
end.
问题二：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事件中编写代码添加附加的注册表信息。
下面是实现的全部程序代码：
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
项注册服务器。好了，看看效果吧。
Windows操作系统具有用户界面的可扩充性。可以通过多种方式来增强系统的外壳。通过对外壳的扩展，
开发人员可以为用户提供其他的文件对象操作方式或者简化文件系统和网络的浏览，或者使用户能更方便地调用
文件系统中对各种对象进行处理的工具。例如，给一些特殊的文件夹赋予与众不同的图标、可以向外壳对象上下
文相关菜单动态地添加命令等等。这都是依靠Windows外壳扩展(Shell Extensions)。
1．外壳扩展概述
下面是与外壳扩展相关的三个重要术语：
(1)文件对象(File Object)
文件对象是外壳中的一项，大家最熟识的文件对象是文件和目录，此外，打印机、控制面板程序、共享网络
等也都是文件对象。
(2)文件类(File Class)
文件类是具有某种共同特性的文件对象的集合，比如，扩展名相同的文件属于同一文件类。
(3)处理程序(Handler)
处理程序是具体实现某个外壳扩展的代码。
Windows支持七种类型的外壳扩展（称为Handler），它们相应的作用简述如下：
(1)Context menu handlers向特定类型的文件对象增添上下文相关菜单；
(2)Drag-and-drop handlers用来支持当用户对某种类型的文件对象进行拖放操作时的OLE数据传输；
(3)Icon handlers用来向某个文件对象提供一个特有的图标，也可以给某一类文件对象指定图标；
(4)Property sheet handlers给文件对象增添属性页，属性页可以为同一类文件对象所共有，也可以
给一个文件对象指定特有的属性页；
(5)Copy-hook handlers在文件夹对象或者打印机对象被拷贝、移动、删除和重命名时，就会被系统调
用，通过为Windows增加Copy-hook handlers，可以允许或者禁止其中的某些操作；
(6)Drop target handlers在一个对象被拖放到另一个对象上时，就会被系统被调用；
(7)Data object handlers在文件被拖放、拷贝或者粘贴时，就会被系统被调用。
Windows的所有外壳扩展都是基于COM(Component Object Model) 组件模型的，外壳是通过接口
(Interface)来访问对象的。外壳扩展被设计成32位的进程中服务器程序，并且都是以动态链接库的形式为
操作系统提供服务的。因此，如果要对Windows的用户界面进行扩充的话，则具备写COM对象的一些知识是十
分必要的。写好外壳扩展程序后，必须将它们注册才能生效。所有的外壳扩展都必须在注册表的
HKEY_CLASSES_ROOT/CLSID键之下进行注册。
在该键下面可以找到许多名字像{0000002F-0000-0000-C000-000000000046}的键，这类键就是全局
唯一类标识符。每一个外壳扩展都必须有一个全局唯一类标识符，Windows正是通过此唯一类标识符来找到外
壳扩展处理程序的。在类标识符之下的InProcServer32子键下记录着外壳扩展动态链接库在系统中的位置。
与某种文件类型关联的外壳扩展注册在相应类型的shellex主键下。如果所处的Windows操作系统为
Windows NT，则外壳扩展还必须在注册表中的
HKEY_LOCAL_MACHINE/Software/Microsoft/Windows/CurrentVersion/ShellExtensions/App
roved主键下登记。
注册表HKEY_CLASSES_ROOT主键下有几个特殊的子键，如*、Folder、Drive以及Printer。如果把
外壳扩展注册在*子键下，那么这个外壳扩展将对Windows中所有类型的文件有效；如果把外壳扩展注册在
Folder子键下，则对所有目录有效。以下是在*子键下注册的外壳扩展的一个示例（其中登记了一个属性页和
一个WinZip提供的上下文相关菜单处理程序）：
[HKEY_CLASSES_ROOT/*/shellex]
@=""
[HKEY_CLASSES_ROOT/*/shellex/PropertySheetHandlers]
[HKEY_CLASSES_ROOT/*/shellex/PropertySheetHandlers/{3EA48300-8CF6-101B-84FB-666C
CB9BCD32}]
@=""
[HKEY_CLASSES_ROOT/*/shellex/ContextMenuHandlers]
@=""
[HKEY_CLASSES_ROOT/*/shellex/ContextMenuHandlers/WinZip]
@="{E0D79300-84BE-11CE-9641-444553540000}"
注册外壳扩展的DLL程序可以用Windows提供的regsvr32.exe。也可以使用Delphi的Run菜单中的
Register ActiveX Server来注册。
如前所述，Windows的外壳扩展都是基于微软公司的COM组件模型的，从这个意义上来讲，编写外壳扩展
的过程其实就是构造COM对象的过程。但由于各种外壳对象的功能不同，它们要遵循的规则也不同。鉴于
Context Menu Handler这种类型的外壳扩展的应用性比较广，下面以一个实例来具体介绍Context Menu
Handler外壳扩展的实现方法。只要熟练地掌握了其中一种外壳扩展程序的编写方法，在需要编写其他类型的
外壳扩展时再具体查阅一下相应的规则，就可以比较容易地实现其他类型的外壳扩展了。建议读者到微软公司的
网站上去找相关资料，为此先进入http://www.microsoft.com站点，然后单击Search按钮，输入Shell
extension作为关键字，查找范围应选Developer Resources，再按Search按钮即可。
2．上下文相关菜单处理程序的编写
在Windows中，用鼠标右键单击文件或者文件夹时弹出的那个菜单便称为上下文相关菜单。要动态地在上
下文相关菜单中增添菜单项，可以通过写Context Menu Handler来实现。比如大家所熟悉的WinZip和
UltraEdit等软件都是通过编写Context Menu Handler来动态地向菜单中增添菜单项的。如果系统中安
装了WinZip，那么当用右键单击一个名为abc的文件（夹）时，其上下文相关菜单就会有一个名为Add to
abc.zip的菜单项。本文要实现的Context Menu Handler与WinZip提供的上下文菜单相似，它将在任
意类型文件的上下文菜单中增加一个名为“用写字板打开XXX”（其中XXX为当前选定的文件名称）的菜单项，
只要你选择该菜单项，Windows就会启动写字板并打开当前所选的文件
编写Context Menu Handler必须实现IShellExtInit和IContextMenu两个接口。除了IUnknown
接口所定义的函数之外，Context Menu Handler还需要用到QueryContextMenu、InvokeCommand和
GetCommandString这三个非常重要的成员函数。
(1)QueryContextMenu函数：每当系统要显示一个文件对象的上下文相关菜单时，它首先要调用该函数。
为了在上下文相关菜单中添加菜单项，我们在该函数中调用InsertMenu函数。
(2)InvokeCommand函数：当用户选定了某个Context Menu Handler登记过的菜单项后，该函数将
会被调用，系统将会传给该函数一个指向LPCMINVOKECOMMANDINFO结构的指针。在该函数中要执行与所选
菜单项相对应的操作。
(3)GetCommandString函数：当鼠标指针移到一个上下文相关菜单项上时，在当前窗口的状态条上将会
出现与该菜单项相关的帮助信息，此信息就是系统通过调用该函数获取的。
具体编写方法请参阅网上的程序实例，网址为www.pccomputing.com.cn。
3．增添上下文相关菜单项说明
如果要静态地为目录或者某一类文件增添上下文相关菜单项，那么就用不着编写Context Menu Handler，
可以通过直接修改Windows注册表来达到此目的。比如，可以将下面的内容存成一个扩展名为.REG的文件，
然后双击它将其导入注册表，你会发现所有类型文件的上下文相关菜单中都多了一个名叫“记事本”的菜单项。
REGEDIT4
[HKEY_CLASSES_ROOT/*/shell/记事本]
[HKEY_CLASSES_ROOT/*/shell/记事本/command]
@="notepad.exe/"%1/""
通过比较，很容易发现这两种方式所得结果的差异。通过直接修改注册表来增添菜单项的确比较简单，然而
它不具有交互性，所增添的菜单项是静态的，并且所能实现的功能也非常有限。但是Context Menu Handler
则不同，它使我们可以根据上下文的具体情况动态地添加菜单项，比如可以判断当前选定的是哪一类文件、是不
是文件夹、选定的文件（夹）的个数以及获取被选定文件（夹）的属性。有时，这些信息对于程序很有用，如果
需要得到此类信息，并且需要根据不同的上下文来执行不同的操作，那么只好依靠Context Menu Hander来
实现。本例中，其动态性体现在仅当用户选定了一个文件时，才会在上下文相关菜单中增添菜单项，并且菜单项
的名字随着所选文件名的不同而相应地变化。
上下文相关菜单处理程序编写方法的实例。
//Context Menu Handler
//Written Nov 1998 by Ming-Hua LIU
//E-mail: minghua_liu@263.net
unit ContextMenuHandler;
interface
uses Windows,ActiveX,ComObj,ShlObj;
type
TContextMenu = class(TComObject,IShellExtInit,IContextMenu)
private
FFileName: array[0..MAX_PATH] of Char;
protected
{ IShellExtInit }
function IShellExtInit.Initialize = SEIInitialize; // Avoid compiler warning
function SEIInitialize(pidlFolder: PItemIDList; lpdobj: IDataObject;
hKeyProgID: HKEY): HResult; stdcall;
{ IContextMenu }
function QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst, idCmdLast,
uFlags: UINT): HResult; stdcall;
function InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult; stdcall;
function GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HResult; stdcall;
end;
const
Class_ContextMenu: TGUID = '{19780513-C829-11D1-8233-0020AF3E97A9}';
{全局唯一标识符(GUID)是一个16字节（128为）的值，它唯一地标识一个接口(interface)}
implementation
uses ComServ, SysUtils, ShellApi, Registry;
function TContextMenu.SEIInitialize(pidlFolder: PItemIDList; lpdobj:
IDataObject;
hKeyProgID: HKEY): HResult;
var
StgMedium: TStgMedium;
FormatEtc: TFormatEtc;
begin
//如果lpdobj等于Nil，则本调用失败
if (lpdobj = nil) then begin
Result := E_INVALIDARG;
Exit;
end;
with FormatEtc do begin
cfFormat := CF_HDROP;
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;
Result := lpdobj.GetData(FormatEtc, StgMedium);
if Failed(Result) then Exit;
{用DragQueryFile函数来查询选定的文件的个数。本例中仅当只选定
一个文件时才在上下文相关菜单中增加菜单项。}
if (DragQueryFile(StgMedium.hGlobal,$FFFFFFFF,nil,0) = 1) then begin
DragQueryFile(StgMedium.hGlobal, 0, FFileName, SizeOf(FFileName));
Result := NOERROR;
end
else begin
FFileName[0] := #0;
Result := E_FAIL;
end;
ReleaseStgMedium(StgMedium);
end;
function TContextMenu.QueryContextMenu(Menu: HMENU; indexMenu, idCmdFirst,
idCmdLast, uFlags: UINT): HResult;
begin
Result := 0;
if ((uFlags and $0000000F) = CMF_NORMAL) or
((uFlags and CMF_EXPLORE) <> 0) then begin
// 往Context Menu中加入一个菜单项
InsertMenu(Menu, indexMenu, MF_STRING or MF_BYPOSITION, idCmdFirst,
PChar('用写字板打开 '+ExtractFileName(FFileName)));
// 返回增加菜单项的个数
Result := 1;
end;
end;
function TContextMenu.InvokeCommand(var lpici: TCMInvokeCommandInfo): HResult;
var
H: THandle; WordpadPath:String; Reg:TRegistry;
begin
// Make sure we are not being called by an application
if (HiWord(Integer(lpici.lpVerb)) <> 0) then
begin
Result := E_FAIL;
Exit;
end;
// Make sure we aren't being passed an invalid argument number
if (LoWord(lpici.lpVerb) <> 0) then begin
Result := E_INVALIDARG;
Exit;
end;
//当用户选定'用写字板打开XXX'时，执行WordPad.exe
//先获取WordPad.exe的路径
Reg:=TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
Reg.OpenKeyReadOnly('SOFTWARE/Microsoft/Windows/CurrentVersion/App
Paths/WORDPAD.EXE');
WordpadPath:=Reg.ReadString('');//注意：两个撇号(')之间无空格
Reg.Free;
H := WinExec(PChar(WordPadPath+' ' +'"'+FfileName+'"'), lpici.nShow);
//注意：最前一对撇号(')之间为空格，后两对撇号中为双引号。
if (H < 32) then
MessageBox(lpici.hWnd, '执行写字板时出错！', '错误', MB_ICONERROR+MB_OK);
Result := NOERROR;
end;
function TContextMenu.GetCommandString(idCmd, uType: UINT; pwReserved: PUINT;
pszName: LPSTR; cchMax: UINT): HRESULT;
begin
if (idCmd = 0) then begin
if (uType = GCS_HELPTEXT) then
{返回该菜单项的帮助信息，此帮助信息将在用户把鼠标移动到该菜单项时出现在状态条上。}
StrCopy(pszName, PChar('用写字板打开'+FFileName));
Result := NOERROR;
end
else
Result := E_INVALIDARG;
end;
type
TContextMenuFactory = class(TComObjectFactory)
public
procedure UpdateRegistry(Register: Boolean); override;
end;
procedure TContextMenuFactory.UpdateRegistry(Register: Boolean);
var
ClassID: string;
begin
if Register then begin
inherited UpdateRegistry(Register);
ClassID := GUIDToString(Class_ContextMenu);
CreateRegKey('*/shellex', '', '');
CreateRegKey('*/shellex/ContextMenuHandlers', '', '');
CreateRegKey('*/shellex/ContextMenuHandlers/OpenWithWordPad', '', ClassID);
//如果操作系统为Windows NT的话
if (Win32Platform = VER_PLATFORM_WIN32_NT) then
with TRegistry.Create do
try
RootKey := HKEY_LOCAL_MACHINE;
OpenKey('SOFTWARE/Microsoft/Windows/CurrentVersion/Shell Extensions', True);
OpenKey('Approved', True);
WriteString(ClassID, 'Context Menu Shell Extension');
finally
Free;
end;
end
else begin
DeleteRegKey('*/shellex/ContextMenuHandlers/OpenWithWordPad');
DeleteRegKey('*/shellex/ContextMenuHandlers');
DeleteRegKey('*/shellex');
inherited UpdateRegistry(Register);
end;
end;
initialization
TContextMenuFactory.Create(ComServer, TContextMenu, Class_ContextMenu,
'', 'Context Menu Shell Extension', ciMultiInstance,
tmApartment);
end.
工程文件(*.DPR)的内容如下：
// This COM server defines a Context Menu shell extension.
library ContextMenu;
uses
ComServ,
ContextMenuHandler in 'ContextMenuHandler.pas',
contmenu_TLB in 'contmenu_TLB.pas';
exports
DllGetClassObject,
DllCanUnloadNow,
DllRegisterServer,
DllUnregisterServer;
{$R *.TLB}
{$R *.RES}
begin
end.
问题二：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事件中编写代码添加附加的注册表信息。
下面是实现的全部程序代码：
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
项注册服务器。好了，看看效果吧。
L
lfpsoft
Unregistered / Unconfirmed
GUEST, unregistred user!
如果是要在任何程序的窗口的图标的菜单里加入自己的项呢，可以实现吗？
D
delphi浪客
Unregistered / Unconfirmed
GUEST, unregistred user!
这就叫超难？不就是个外壳程序吗？。。技术资料满天飞的
google输入“delphi WINDOWS外壳”enter。。多的你眼花。。靠。超难。。果然吸引观众
google输入“delphi WINDOWS外壳”enter。。多的你眼花。。靠。超难。。果然吸引观众
N
netwinds
Unregistered / Unconfirmed
GUEST, unregistred user!
TO
delphi浪客
靠，你牛未必每个人都象你一样牛，对吧。有本事是你的历害，咱这菜鸟当然只能夸张
点了。
鸟什么鸟，真是的！！！等别人答出来了才来这里狂穷吼！
谢谢大家，接受答案了
delphi浪客
靠，你牛未必每个人都象你一样牛，对吧。有本事是你的历害，咱这菜鸟当然只能夸张
点了。
鸟什么鸟，真是的！！！等别人答出来了才来这里狂穷吼！
谢谢大家，接受答案了
