利用Delphi編寫IE擴充套件 (轉)
就是如何使IE擴充套件可以響應事件。
在自己的中使用過Browser的朋友都知道，WebBrowser控制元件定義了諸如BeforeNavigate、Complete 等事件，我們可以透過編寫事件處理程式碼實現對WebBrowser控制元件的操作。那麼如何實現對IE的事件響應和處理呢？同建立IE皮膚一樣。我們需要建立一個實現IWithSite介面的COM元件，不同的是，我們還需要實現IDispatch介面，在IObjectWithSite介面的SetSite方法中獲得IE的WebBrowser介面並建立自身與WebBrowser的連線，然後如果在IE的Webbrowser中發生什麼事件的話，那麼IE就會回撥連線的IDispatch介面的Invoke方法。我們透過在Invoke方法中編寫程式碼就可以獲得IE事件了。這個利用的是COM的回撥介面原理。
下面我們首先來實現程式碼。點選選單 File | New 。在 頁面中選擇Active Library ，然後點選 OK 按鈕。然後用同樣的方法建立一個Object。在COM Object Wizard 視窗中，將核取方塊 Included type library 去掉。然後在Class Name中輸入IEHelper，在Implemented Interface 中輸入：IDispatch；IObjectwithSite 。然後點選 OK 按鈕建立一個COM元件。
儲存工程，將工程儲存為IEHelper.dpr，將Unit1儲存為IEHelperUnit.pas。下面是IEHelperUnit.pas的具體程式碼：
unit iehelperunit;
interface
uses
, Comobj, ActiveX, SHDOCVW, MSHTML,Dialogs;
type
TIEHelperFactory = class(TComObjectFactory)
private
procedure AddKeys;
procedure RemoveKeys;
public
procedure UpdateRegistry(Register: Boolean); overr;
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: ; 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: Worool);
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<>''then begin
Showmessage('你不可以瀏覽其它站點');
Cancel:=True;
;
(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 DoOnStatar(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;
bHarams: 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;
try
if (bHasParams) then BuildPositionalDispIds(pDispIds, dps);
case DispId of
102:
begin
DoStatusTextChange(dps.rgvarg^[pDispIds^[0]].bstrval);
Result := S_OK;
end;
108:
begin
DoProgressChange(dps.rgvarg^[pDispIds^[0]].lval, dps.rgvarg^[pDispIds^[1]].lval);
Result := S_OK;
end;
105:
begin
DoCommandStateChange(dps.rgvarg^[pDispIds^[0]].lval, dps.rgvarg^[pDispIds^[1]].vbool);
Result := S_OK;
end;
106:
begin
DoDownloadBegin();
Result := S_OK;
end;
104:
begin
DoDownloadComplete();
Result := S_OK;
end;
113:
begin
DoTitleChange(dps.rgvarg^[pDispIds^[0]].bstrval);
Result := S_OK;
end;
112:
begin
DoPropertyChange(dps.rgvarg^[pDispIds^[0]].bstrval);
Result := S_OK;
end;
250:
begin
DoBeforeNavigate2(IDispatch(dps.rgvarg^[pDispIds^[0]].dispval), POleVariant(dps.rgvarg^[pDispIds^[1]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[2]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[3]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[4]].pvarval)^, POleVariant(dps.rgvarg^[pDispIds^[5]].pvarval)^, dps.rgvarg^[pDispIds^[6]].pbool^);
Result := S_OK;
end;
251:
begin
DoNewWindow2(IDispatch(dps.rgvarg^[pDispIds^[0]].pdispval^), dps.rgvarg^[pDispIds^[1]].pbool^);
Result := S_OK;
end;
252:
begin
DoNavigateComplete2(IDispatch(dps.rgvarg^[pDispIds^[0]].dispval), POleVariant(dps.rgvarg^[pDispIds^[1]].pvarval)^);
Result := S_OK;
end;
259:
begin
DoDocumentComplete(IDispatch(dps.rgvarg^[pDispIds^[0]].dispval), POleVariant(dps.rgvarg^[pDispIds^[1]].pvarval)^);
Result := S_OK;
end;
253:
begin
DoOnQuit();
Result := S_OK;
end;
254:
begin
DoOnVisible(dps.rgvarg^[pDispIds^[0]].vbool);
Result := S_OK;
end;
255:
begin
DoOnToolBar(dps.rgvarg^[pDispIds^[0]].vbool);
Result := S_OK;
end;
256:
begin
DoOnMenuBar(dps.rgvarg^[pDispIds^[0]].vbool);
Result := S_OK;
end;
257:
begin
DoOnStatusBar(dps.rgvarg^[pDispIds^[0]].vbool);
Result := S_OK;
end;
258:
begin
DoOnFullScreen(dps.rgvarg^[pDispIds^[0]].vbool);
Result := S_OK;
end;
260:
begin
DoOnTheaterMode(dps.rgvarg^[pDispIds^[0]].vbool);
Result := S_OK;
end;
end;
finally
if (bHasParams) then FreeMem(pDispIds, iDispIdsSize);
end;
end;
function TIEHelper.GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
Result := E_NOTIMPL;
end;
function TIEHelper.GetTypeInfo(Index, LocaleID: Integer;
out TypeInfo): HResult;
begin
Result := E_NOTIMPL;
pointer(TypeInfo) := nil;
end;
function TIEHelper.GetTypeInfoCount(out Count: Integer): HResult;
begin
Result := E_NOTIMPL;
Count := 0;
end;
function TIEHelper.GetSite(const riid: TIID; out site: IUnknown): HResult;
begin
// Result := S_OK;
if Assigned(IE) then result:=IE.QueryInterface(riid, site)
else
Result:= E_FAIL;
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
Key := HKEY_LOCAL_MACHINE;
if OpenKey('SoftwareWindowsCurrentVersionexplorerBrowser 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('SoftwareMicrosoftWindowsCurrentVersionexplorerBrowser 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，在該函式中，如果瀏覽的站點不是''的話，程式會提示：'你不可以瀏覽其它站點'並強行轉到。
很多的，象“護花使者”以及“3721”一類的中文網址”都是利用上面的原理來實現對IE事件響應的，例如3721，當輸入一箇中文詞並瀏覽時，COM元件可以在BeforeNavigate2 事件中編寫程式碼訪問並轉到正確的站點上去。
以上程式在、Delphi 5下編寫 、Win2K下編輯透過，如果大家需要源程式或者對於COM程式設計需要有什麼的指教的話，歡迎到我的主頁 訪問，我願意同大家一起探討。
來自 “ ITPUB部落格 ” ，連結：http://blog.itpub.net/10752043/viewspace-987899/，如需轉載，請註明出處，否則將追究法律責任。
相關文章
- 利用Delphi編寫IE擴充套件套件
- 利用Delphi編寫Windows外殼擴充套件 (轉)Windows套件
- 充分利用Windows API擴充套件Delphi函式 (轉)WindowsAPI套件函式
- Ace Editor 擴充套件編寫初步（轉）套件
- 編寫可擴充套件程式套件
- 編寫自己的php擴充套件函式 (轉)PHP套件函式
- 為Unity元件編寫擴充套件Unity元件套件
- 利用DELPHI編寫WINDOWS外殼 (轉)Windows
- 編寫自己的php擴充套件函式（一） (轉)PHP套件函式
- 擴充套件Delphi的執行緒同步物件(1) (轉)套件執行緒物件
- PHP擴充套件開發教程2 – 編寫第一個擴充套件 hello worldPHP套件
- Linux下編寫一個PHP擴充套件LinuxPHP套件
- Go 語言編寫 CPython 擴充套件 goPyGoPython套件
- 編寫基於PHP擴充套件庫的後門PHP套件
- 如何編寫一個獨立的 PHP 擴充套件PHP套件
- 利用 phpize 安裝 openssl 擴充套件PHP套件
- 一步步入門編寫PHP擴充套件PHP套件
- 利用Windows外殼擴充套件保護資料夾 (轉)Windows套件
- 為PHP編譯imap擴充套件PHP編譯套件
- kotlin 擴充套件（擴充套件函式和擴充套件屬性）Kotlin套件函式
- 使用 Cython 為 Python 編寫更快的 C 擴充套件Python套件
- 如何編寫Vault外掛擴充套件Vault Explorer的功能套件
- OpenGL 1.3 最新擴充套件 (轉)套件
- 擴充套件你的STRUTS (轉)套件
- IE CSS Bug系列：高度額外擴充套件的BugCSS套件
- 用Delphi編寫DelTree程式 (轉)
- 【譯】12個編寫乾淨且可擴充套件的JavaScript技巧套件JavaScript
- EFCore3.1+編寫自定義的EF.Functions擴充套件方法Function套件
- 通過編寫指令碼和程式來擴充套件SSIS包NZ指令碼套件
- [TIL] 使用scrcpy映象安卓裝置+編寫一個Raycast擴充套件安卓AST套件
- WCF擴充套件：行為擴充套件Behavior Extension套件
- gcc核心擴充套件linuxforum(轉)GC套件Linux
- php利用pcntl擴充套件實現高併發PHP套件
- [擴充套件推薦]簡體轉繁體/繁體轉簡體 OpenCC-PHP 擴充套件套件PHP
- 【Kotlin】擴充套件屬性、擴充套件函式Kotlin套件函式
- 編寫"谷歌擴充套件"便捷"自測"埋點上報資訊是否正確谷歌套件
- OpenRTMFP/Cumulus Primer（2）用Lua編寫HelloWorld應用擴充套件CumulusServer套件Server
- 【記錄】編譯安裝 ProtoBuf 擴充套件編譯套件