如题
解决方案 »
- 如何使显示的窗体呈不激活状态???
- 特急:: DBGridEh1.SelectedRows.Delete; 这个执行时出错,BOF 或 EOF 中有一个是"真",或者当前的记录已被删除
- 图片存取,用什么工具编程更好?
- 急!如何分别读取当前时间的小时、分钟和秒!
- 怎么在程序中改变数据库的库结构!!!!!!!!!!!!急
- DrawGrid初始化时不能装入图像的问题
- 请问怎样获得制定文件类型的图标?
- 多个开发工具混合使用的思考!!
- 菜鸟求救:关于动态产生的按钮怎样编辑它的点击事件,给分100
- 急急急!!关于Delphi7+intraweb控件,基于B/S结构,对Mysql数据库表进行数据操作!
- 为什么你看不到新贴了.没有15号的贴子全是14号以后的贴子?
- 请问如何将菜单和Coolbar绑定在一起,就如同Delphi5自己的菜单?
unit iehelperunit;
interface
uses WIndows, Comobj, ActiveX, SHDOCVW, MSHTML,Dialogs; type
TIEHelperFactory = class(TComObjectFactory) private procedure AddKeys; procedure RemoveKeys; public procedure UpdateRegistry(Register: Boolean); override; end; TIEHelper = class(TComObject, IDispatch, IObjectWithSite) public function GetTypeInfoCount(out Count: Integer): HResult; stdcall; function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall; function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall; function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall; function SetSite(const pUnkSite: IUnknown): HResult; stdcall; function GetSite(const riid: TIID; out site: IUnknown): HResult; stdcall; private IE: IWebbrowser2; Cookie: Integer; end;
const Class_IEHelper: TGUID = ’{3D898C55-74CC-4B7C-B5F1-45913F368388}’; implementation
uses ComServ, Registry, SysUtils; procedure DoStatusTextChange(const Text: WideString); begin
end;
procedure DoProgressChange(Progress: Integer; ProgressMax: Integer); begin
end;
procedure DoCommandStateChange(Command: Integer; Enable: WordBool); begin
end;
procedure DoDownloadBegin; begin
end;
procedure DoDownloadComplete; begin
end;
procedure DoTitleChange(const Text: WideString); begin
end;
procedure DoPropertyChange(const szProperty: WideString); begin
end;
procedure DoBeforeNavigate2(const pDisp: IDispatch; var URL: OleVariant; var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers: OleVariant; var Cancel: WordBool); begin if URL<>’http://www.applevb.com/’then begin Showmessage(’你不可以浏览其它站点’); Cancel:=True; URL:=’http://www.applevb.com’; (pDisp as IWebbrowser2).Navigate2(URL,Flags,TargetFrameName,PostData,Headers); end; end;
procedure DoNewWindow2(var ppDisp: IDispatch; var Cancel: WordBool); begin
end;
procedure DoNavigateComplete2(const pDisp: IDispatch; var URL: OleVariant); begin
end;
procedure DoDocumentComplete(const pDisp: IDispatch; var URL: OleVariant); begin
end;
procedure DoOnQuit; begin
end;
procedure DoOnVisible(Visible: WordBool); begin
end;
procedure DoOnToolBar(ToolBar: WordBool); begin
end;
procedure DoOnMenuBar(MenuBar: WordBool); begin
end;
procedure DoOnStatusBar(StatusBar: WordBool); begin
end;
procedure DoOnFullScreen(FullScreen: WordBool); begin
end;
procedure DoOnTheaterMode(TheaterMode: WordBool); begin
end; procedure BuildPositionalDispIds(pDispIds: PDispIdList; const dps: TDispParams); var i: integer; begin Assert(pDispIds <> nil); for i := 0 to dps.cArgs - 1 do pDispIds^[i] := dps.cArgs - 1 - i; if (dps.cNamedArgs <= 0) then Exit; for i := 0 to dps.cNamedArgs - 1 do pDispIds^[dps.rgdispidNamedArgs^[i]] := i; end;
function TIEHelper.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; type POleVariant = ^OleVariant; var dps: TDispParams absolute Params; bHasParams: boolean; pDispIds: PDispIdList; iDispIdsSize: integer; begin Result := DISP_E_MEMBERNOTFOUND; pDispIds := nil; iDispIdsSize := 0; bHasParams := (dps.cArgs > 0); if (bHasParams) then begin iDispIdsSize := dps.cArgs * SizeOf(TDispId); GetMem(pDispIds, iDispIdsSize); end;
function TIEHelper.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; begin Result := E_NOTIMPL; pointer(TypeInfo) := nil; end;
function TIEHelper.SetSite(const pUnkSite: IUnknown): HResult; var cmdTarget: IOleCommandTarget; Sp: IServiceProvider; CPC: IConnectionPointContainer; CP: ICOnnectionPoint; begin if Assigned(pUnkSite) then begin cmdTarget := pUnkSite as IOleCommandTarget; Sp := CmdTarget as IServiceProvider;
if Assigned(Sp)then Sp.QueryService(IWebbrowserApp, IWebbrowser2, IE); if Assigned(IE) then begin IE.QueryInterface(IConnectionPointContainer, CPC); CPC.FindConnectionPoint(DWEBbrowserEvents2, CP); CP.Advise(Self, Cookie) end; end; Result := S_OK; end; procedure TIEHelperFactory.AddKeys; var S: string; begin S := GUIDToString(CLASS_IEHelper); with TRegistry.Create do try RootKey := HKEY_LOCAL_MACHINE; if OpenKey(’Software\Microsoft\Windows\CurrentVersion\explorer\Browser Helper Objects\’ + S, TRUE) then CloseKey; finally free; end; end;
procedure TIEHelperFactory.RemoveKeys; var S: string; begin S := GUIDToString(CLASS_IEHelper); with TRegistry.Create do try RootKey := HKEY_LOCAL_MACHINE; DeleteKey(’Software\Microsoft\Windows\CurrentVersion\explorer\Browser Helper Objects\’ + S); finally free; end; end;
procedure TIEHelperFactory.UpdateRegistry(Register: Boolean); begin inherited UpdateRegistry(Register); if Register then AddKeys else RemoveKeys; end;
initialization TIEHelperFactory.Create(ComServer, TIEHelper, Class_IEHelper, ’IEHelper’, ’’, ciMultiInstance, tmApartment); end.
代码很长,但是关键的是TIEHelper.SetSite方法以及TIEHelper.Invoke方法。在TIEHelper.SetSite方法中注意以下语句: if Assigned(Sp)then Sp.QueryService(IWebbrowserApp, IWebbrowser2, IE); if Assigned(IE) then begin IE.QueryInterface(IConnectionPointContainer, CPC); CPC.FindConnectionPoint(DWEBbrowserEvents2, CP); CP.Advise(Self, Cookie)
上面的语句作用是,首先获得IE的Webbrowser接口,然后寻找到连接点。并通过Advise方法建立COM自身与连接点的连接。 当连接建立成功后,IE在有事件引发后,会调用连接到自身的IDispatch接口对象的Invoke方法。不同的事件对应不同的DispID编码,我们可以在程序中判断DispID并做相应的处理。在上面的程序中,我们只处理了BeforeNavigate2 事件,处理函数是DoBeforeNavigate2,在该函数中,如果浏览的站点不是’http://www.applevb.com/’的话,程序会提示:’你不可以浏览其它站点’并强行转到http://www.applevb.com。 很多的软件,象“护花使者”以及“3721”一类的中文网址”都是利用上面的原理来实现对IE浏览器事件响应的,例如3721,当用户输入一个中文词并浏览时,COM组件可以在BeforeNavigate2 事件中编写代码访问服务器并转到正确的站点上去。
我只是简单的看了一下,还没有研究过,好像您主要提到的是如何得到IE的事件,不过我希望可以将一个空件嵌到IE的工具条里面去。不知用此方法是否可行。