基于delphi的bho开发笔记

杨峰

个人信息

性别:无法查看,请先登录
地区:**
Email:**
QQ:**
MSN:**
主页:**

日志 - 日历

2008 9.6 Sat
日	一	二	三	四	五	六
	1	2	3	4	5	6
7	8	9	10	11	12	13
14	15	16	17	18	19	20
21	22	23	24	25	26	27
28	29	30
« 年 » 2008 - 9 « 月 »

博客基本信息

用户名: mailysf
等级: 幼儿园娃娃
在线时间: 1975 分钟
日志总数: 22
评论数量: 18
访问次数: 80294
建立时间: 2007-07-06

XML

RSS 2.0

WAP

我的日志

作者: mailysf

复制

基于delphi的bho开发笔记2007-07-27

天终于解决了让我头疼了很久的在IE工具条上backspace和tab键无效的问题，具体的解决方法如下：（这是个demo的文件）

主要要实现接口：IInputObject;

    {Declare IInputObject methods here}
    function UIActivateIO(fActivate: BOOL; var lpMsg: TMsg): HResult; stdcall;
    function HasFocusIO: HResult; stdcall;
    function TranslateAcceleratorIO(var lpMsg: TMsg): HResult; stdcall;

以及方法：

procedure FocusChange(bHasFocus: Boolean);
procedure BandWndProc(var Message: TMessage);

具体请看以下demo代码：

窗体文件：

unit fmIEBar;

interface

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

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

var
frmIEBar: TfrmIEBar;

implementation

{$R *.dfm}

{ TfrmIEBar }

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

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

end.

具体实现文件：

unit UTestTextBox;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
Windows, ActiveX, Classes, ComObj, MSHTML, SHDocVw, ShellAPI, TlHelp32, ShlObj, fmIEBar,
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;
    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;
begin
if Assigned(frmIE) and (frmIE.Active) then
begin
Result := S_OK;
end
else
begin
Result := E_FAIL;
end;
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.

原创文章如转载，请注明：转载自Delphi背影 [ http://mailysf.blog.zj.com/ ]
本文链接地址：http://mailysf.blog.zj.com/blog/d-143742.html

上一篇:Intraweb开发Web平台

下一篇:基于Delphi的BHO开发基础