往IE中嵌入工具條 (轉)

往IE中嵌入工具條 (轉)[@more@]

我們首先要建立一個 Library。將其儲存為IEBand.Dpr；然後建立一個，將其儲存為BandUnit.pas；然後建立一個Form，這個視窗將作為子視窗顯示在IE工具欄中，將視窗的BorderStyle屬性改為bsNone，新增一個TButton和一個TComboBox元件，將TButton的Caption屬性改為獲取全部，然後將視窗其儲存為IEForm.pas。
在BandUnit中，需要建立一個實現上面提到的介面的TComObject。如下：
TGetMailBand = class(TComObject, skBand, IObjectWithSite, IPersistStreamInit)

另外由於需要在COM註冊時新增一些登錄檔資訊，所以還需要建立一個繼承自TComObjectFactory類的物件，在物件的UpdateRegistry事件中編寫程式碼新增附加的登錄檔資訊。
下面的清單1-6到1-8是實現COM伺服器的全部程式程式碼：

程式清單1-6 MailIEBand.dpr
library MailIEBand;

uses
  ComServ,
  BandUnit in 'BandUnit.pas',
  IEFoin '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
  , Sysutils, Messages, Registry, , ActiveX, Classes, ComObj,
  Shlobj, Dialogs, Commctrl,ShDocVW,IEForm;

type
  TGetMailBand = class(TComObject, IDeskBand, IObjectWithSite, IPersistStreamInit)
  private
  fE: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: D; var pi: 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_SInteExplorer : TGUID = '{0002DF05-0000-0000-C000-000000000046}';
  sIID_IBrowserApp : 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 frmdo 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;

//TIEClasac類實現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
  //新增附加的登錄檔項
  Key:=HKEY_LOCAL_MACHINE;
  OpenKey('SOFTWAREInternet ExplorerToolbar',False);
  a:=0;
  WriteBinaryData(GUIDToString(Class_GetMailBand),a,0);
  OpenKey('SOFTWAREMicrosoftWindowsCurrentVersionShell ExtensionsApproved',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('SOFTWAREMicrosoftInternet ExplorerToolbar',False);
  DeleteValue(GUIDToString(Class_GetMailBand));
  OpenKey('SoftwareMicrosoftWindowsCurrentVersionShell ExtensionsApproved',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視窗，然後點選選單的Run | Register ActiveX Server 項註冊伺服器。然後開啟IE，點選選單 察看 | 工具欄 項，可以看到子選單中多了一個GetMailAddress項，選中改項，工具欄就出現在IE工具欄中