Delphi 开发IE Toolbar，解决Backspace按键问题

先说下参考的资料：

1. 主要代码参考 http://mailysf.blog.zj.com/d-143742.html 。是这个博客写的示例为主干。但我在win7（64bit） + IE9下无效，所以参考其他代码做了改动，就成功了。
2. 陈省的博客 http://delphi.sharpplus.com/Delphi/delphi_ie_band.htm 对整个delphi开发IE Toolbar和BHO都有所论述，很不错。
3. 真正解决问题的代码来自于MS， http://support.microsoft.com/kb/196339/en-us 可以下载C++的源码。文章中也说得按键无效的实质问题所在：

Whenever a key is pressed, three things occur:In order to alleviate these problems, WebBand implements IOleControlSite. In the IOleControlSite::OnFocus method, the WebBrowser's IInputObjectSite::OnFocusChangesIS must be called to tell the WebBrowser that WebBand now has the focus. 

1. WebBand's IInputObject::HasFocusIO method is called to see if WebBand currently has the focus.
2. The IInputObject::UIActivateIO method is called to tell WebBand that is being activated.
3. The IInputObject::TranslateAccelerator method is called. It is here that WebBand passes the keystroke to the hosted WebBrowser control. This causes accelerator keys such as backspace and delete to be processed.

下面代码主要都是资料1中的，只是IInputObject::HasFocusIO的实现做了改变。

unit UTestTextBox;

interface

uses
  Windows, ActiveX, Classes, ComObj, MSHTML, SHDocVw, ShellAPI, TlHelp32,
  ShlObj, uIEBar, Dialogs,
  Registry, Messages;

type
  TTestTextBoxFactory = class(TComObjectFactory)
  public
    procedure UpdateRegistry(Register: Boolean); override;
  end;

  TTestTextBox = class(TComObject, IDeskBand, IObjectWithSite,
    IPersistStreamInit, IInputObject)
  private
    HasFocus: Boolean;
    frmIE: TfrmIEBar;
    m_pSite: IInputObjectSite;
    m_hwndParent: HWND;
    m_hWnd: HWND;
    m_dwViewMode: Integer;
    m_dwBandID: Integer;
    m_pBrowseOC: IWebBrowser2;
    SavedWndProc: TWndMethod;
  protected
    procedure FocusChange(bHasFocus: Boolean);
    procedure BandWndProc(var Message: TMessage);
  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;
    { Declare IInputObject methods here }
    function UIActivateIO(fActivate: BOOL; var lpMsg: TMsg): HResult; stdcall;
    function HasFocusIO: HResult; stdcall;
    function TranslateAcceleratorIO(var lpMsg: TMsg): HResult; stdcall;
  end;

const
  Class_TestTextBox: TGUID = '{9FC0A716-35A4-4ACB-8565-EAA1C2D9E0A1}';
  // 以下是系统接口的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 = 23;
  EB_CLASS_NAME = 'BackSpace有效性测试';

implementation

uses ComServ;

{ TTestTextBoxFactory }

procedure TTestTextBoxFactory.UpdateRegistry(Register: Boolean);
var
  classID: string;
  a: Integer;
begin
  inherited UpdateRegistry(Register);
  if Register then
  begin
    classID := GUIDToString(Class_TestTextBox);
    with TRegistry.Create do
    begin
      try
        // 添加附加的注册表项
        RootKey := HKEY_LOCAL_MACHINE;
        OpenKey('\SOFTWARE\Microsoft\Internet Explorer\Toolbar', False);
        a := 0;
        WriteBinaryData(GUIDToString(Class_TestTextBox), a, 0);
        OpenKey('\SOFTWARE\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved',
          True);
        WriteString(GUIDToString(Class_TestTextBox), EB_CLASS_NAME);
        RootKey := HKEY_CLASSES_ROOT;
        OpenKey('\CLSID\' + GUIDToString(Class_TestTextBox), False);
        WriteString('', EB_CLASS_NAME);
      finally
        Free;
      end;
    end;
  end
  else
  begin
    with TRegistry.Create do
    begin
      try
        RootKey := HKEY_LOCAL_MACHINE;
        OpenKey('\SOFTWARE\Microsoft\Internet Explorer\Toolbar', False);
        DeleteValue(GUIDToString(Class_TestTextBox));
        OpenKey('\Software\Microsoft\Windows\CurrentVersion\Shell Extensions\Approved',
          False);
        DeleteValue(GUIDToString(Class_TestTextBox));
      finally
        Free;
      end;
    end;
  end;
end;

{ TTestTextBox }

procedure TTestTextBox.BandWndProc(var Message: TMessage);
begin
  if (Message.Msg = WM_PARENTNOTIFY) then
  begin
    HasFocus := True;
    FocusChange(HasFocus);
  end;
  SavedWndProc(Message);
end;

function TTestTextBox.CloseDW(dwReserved: DWORD): HResult;
begin
  if Assigned(frmIE) then
  begin
    frmIE.Free;
    frmIE := nil;
  end;
  Result := S_OK;
end;

function TTestTextBox.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
begin
  Result := E_NOTIMPL;
end;

procedure TTestTextBox.FocusChange(bHasFocus: Boolean);
begin
  if m_pSite <> nil then
    m_pSite.OnFocusChangeIS(Self, bHasFocus);
end;

function TTestTextBox.GetBandInfo(dwBandID, dwViewMode: DWORD;
  var pdbi: TDeskBandInfo): HResult;
begin
  Result := E_INVALIDARG;
  if not Assigned(frmIE) then
    frmIE := TfrmIEBar.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 TTestTextBox.GetClassID(out classID: TCLSID): HResult;
begin
  classID := Class_TestTextBox;
  Result := S_OK;
end;

function TTestTextBox.GetSite(const riid: TIID; out site: IInterface): HResult;
begin
  if Assigned(m_pSite) then
    Result := m_pSite.QueryInterface(riid, site)
  else
    Result := E_FAIL;
end;

function TTestTextBox.GetSizeMax(out cbSize: Largeint): HResult;
begin
  Result := E_NOTIMPL;
end;

function TTestTextBox.GetWindow(out wnd: HWND): HResult;
begin
  wnd := frmIE.Handle;
  SavedWndProc := frmIE.WindowProc;
  frmIE.WindowProc := BandWndProc;
  Result := S_OK;
end;

function TTestTextBox.HasFocusIO: HResult;
var
  hwndCur, hwndTmp: HWND;
begin
  hwndCur := GetFocus;
  hwndTmp := frmIE.Handle;
  while (hwndCur <> 0) and (hwndTmp <> 0) do
  begin
    if (hwndCur = hwndTmp) then
    begin
      Result := S_OK;
      exit;
    end;
    hwndTmp := Windows.GetWindow(hwndTmp, GW_CHILD);
  end;

  Result := S_FALSE;
end;

function TTestTextBox.InitNew: HResult;
begin
  Result := E_NOTIMPL;
end;

function TTestTextBox.IsDirty: HResult;
begin
  Result := S_FALSE;
end;

function TTestTextBox.Load(const stm: IStream): HResult;
begin
  Result := S_OK;
end;

function TTestTextBox.ResizeBorderDW(var prcBorder: TRect;
  punkToolbarSite: IInterface; fReserved: BOOL): HResult;
begin
  Result := E_NOTIMPL;
end;

function TTestTextBox.Save(const stm: IStream; fClearDirty: BOOL): HResult;
begin
  Result := S_OK;
end;

function TTestTextBox.SetSite(const pUnkSite: IInterface): HResult;
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 := TfrmIEBar.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 TTestTextBox.ShowDW(fShow: BOOL): HResult;
begin
  HasFocus := fShow;
  FocusChange(HasFocus);
  Result := S_OK;
end;

function TTestTextBox.TranslateAcceleratorIO(var lpMsg: TMsg): HResult;
begin
  if (lpMsg.wParam <> VK_TAB) then
  begin
    TranslateMessage(lpMsg);
    DispatchMessage(lpMsg);
    Result := S_OK;
  end
  else
  begin
    Result := S_FALSE;
  end;
end;

function TTestTextBox.UIActivateIO(fActivate: BOOL; var lpMsg: TMsg): HResult;
begin
  HasFocus := fActivate;
  if HasFocus then
    frmIE.SetFocus;
  Result := S_OK;
end;

initialization

TTestTextBoxFactory.Create(ComServer, TTestTextBox, Class_TestTextBox,
  'BackSpace有效性测试', '测试输入框中的BackSpace', ciMultiInstance, tmApartment);

end.

unit uIEBar;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, SHDocVw;

type
  TfrmIEBar = class(TForm)
    TxtUrl: TEdit;
    procedure FormActivate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    IEThis: IWebbrowser2;
  end;

var
  frmIE: TfrmIEBar;

implementation

{$R *.dfm}

procedure TfrmIEBar.FormActivate(Sender: TObject);
begin
  TxtUrl.SetFocus;
end;

end.