资料收集站

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

Comments (0)

Name

Email

Website

Title

Comment

smaller | bigger

Subscribe via email (registered users only)

I have read and agree to the Terms of Usage.

Add Comment