Intercepter les messages d'Internet Explorer

{
This component allows you to intercept Internet Explorer messages such as
"StatusTextChangeEvent", "DocumentCompleteEvent" and so on.

Mit folgende Komponente lassen sich Nachrichten wie
"StatusTextChangeEvent", "DocumentCompleteEvent" usw. von
Internet Explorer Fenstern abfangen.
}

//---- Component Source: Install this component first.

unit IEEvents;

interface

uses
Windows, SysUtils, Classes, Graphics, ComObj, ActiveX, SHDocVW;

type
// Event types exposed from the Internet Explorer interface
TIEStatusTextChangeEvent = procedure (Sender: TObject; const Text: WideString) of object;
TIEProgressChangeEvent = procedure (Sender: TObject; Progress: Integer; ProgressMax:
Integer) of object;
TIECommandStateChangeEvent = procedure (Sender: TObject; Command: Integer; Enable:
WordBool) of object;
TIEDownloadBeginEvent = procedure (Sender: TObject) of object;
TIEDownloadCompleteEvent = procedure (Sender: TObject) of object;
TIETitleChangeEvent = procedure (Sender: TObject; const Text: WideString) of object;
TIEPropertyChangeEvent = procedure (Sender: TObject; const szProperty: WideString) of
object;
TIEBeforeNavigate2Event = procedure (Sender: TObject; const pDisp: IDispatch;
var URL: OleVariant; var Flags: OleVariant; var TargetFrameName: OleVariant;
var PostData: OleVariant; var Headers: OleVariant; var Cancel: WordBool) of object;
TIENewWindow2Event = procedure (Sender: TObject; var ppDisp: IDispatch; var Cancel:
WordBool) of object;
TIENavigateComplete2Event = procedure (Sender: TObject; const pDisp: IDispatch; var URL:
OleVariant) of object;
TIEDocumentCompleteEvent = procedure (Sender: TObject; const pDisp: IDispatch; var URL:
OleVariant) of object;
TIEOnQuitEvent = procedure (Sender: TObject) of object;
TIEOnVisibleEvent = procedure (Sender: TObject; Visible: WordBool) of object;
TIEOnToolBarEvent = procedure (Sender: TObject; ToolBar: WordBool) of object;
TIEOnMenuBarEvent = procedure (Sender: TObject; MenuBar: WordBool) of object;
TIEOnStatusBarEvent = procedure (Sender: TObject; StatusBar: WordBool) of object;
TIEOnFullScreenEvent = procedure (Sender: TObject; FullScreen: WordBool) of object;
TIEOnTheaterModeEvent = procedure (Sender: TObject; TheaterMode: WordBool) of object;

// Event component for Internet Explorer
TIEEvents = class(TComponent, IUnknown, IDispatch)
private
// Private declarations
FConnected: Boolean;
FCookie: Integer;
FCP: IConnectionPoint;
FSinkIID: TGuid;
FSource: IWebBrowser2;
FStatusTextChange: TIEStatusTextChangeEvent;
FProgressChange: TIEProgressChangeEvent;
FCommandStateChange: TIECommandStateChangeEvent;
FDownloadBegin: TIEDownloadBeginEvent;
FDownloadComplete: TIEDownloadCompleteEvent;
FTitleChange: TIETitleChangeEvent;
FPropertyChange: TIEPropertyChangeEvent;
FBeforeNavigate2: TIEBeforeNavigate2Event;
FNewWindow2: TIENewWindow2Event;
FNavigateComplete2: TIENavigateComplete2Event;
FDocumentComplete: TIEDocumentCompleteEvent;
FOnQuit: TIEOnQuitEvent;
FOnVisible: TIEOnVisibleEvent;
FOnToolBar: TIEOnToolBarEvent;
FOnMenuBar: TIEOnMenuBarEvent;
FOnStatusBar: TIEOnStatusBarEvent;
FOnFullScreen: TIEOnFullScreenEvent;
FOnTheaterMode: TIEOnTheaterModeEvent;
protected
// Protected declaratios for IUnknown
function QueryInterface( const IID: TGUID; out Obj): HResult; override;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
// Protected declaratios for IDispatch
function GetIDsOfNames( const IID: TGUID; Names: Pointer; NameCount, LocaleID:
Integer; DispIDs: Pointer): HResult; virtual; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual;
stdcall;
function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtual;
stdcall;
// Protected declarations
procedure DoStatusTextChange( const Text: WideString); safecall;
procedure DoProgressChange(Progress: Integer; ProgressMax: Integer); safecall;
procedure DoCommandStateChange(Command: Integer; Enable: WordBool); safecall;
procedure DoDownloadBegin; safecall;
procedure DoDownloadComplete; safecall;
procedure DoTitleChange( const Text: WideString); safecall;
procedure DoPropertyChange( const szProperty: WideString); safecall;
procedure DoBeforeNavigate2( const pDisp: IDispatch; var URL: OleVariant;
var Flags: OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant;
var Headers: OleVariant; var Cancel: WordBool); safecall;
procedure DoNewWindow2( var ppDisp: IDispatch; var Cancel: WordBool); safecall;
procedure DoNavigateComplete2( const pDisp: IDispatch; var URL: OleVariant); safecall;
procedure DoDocumentComplete( const pDisp: IDispatch; var URL: OleVariant); safecall;
procedure DoOnQuit; safecall;
procedure DoOnVisible(Visible: WordBool); safecall;
procedure DoOnToolBar(ToolBar: WordBool); safecall;
procedure DoOnMenuBar(MenuBar: WordBool); safecall;
procedure DoOnStatusBar(StatusBar: WordBool); safecall;
procedure DoOnFullScreen(FullScreen: WordBool); safecall;
procedure DoOnTheaterMode(TheaterMode: WordBool); safecall;
public
// Public declarations
const ructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ConnectTo(Source: IWebBrowser2);
procedure Disconnect;
property SinkIID: TGuid read FSinkIID;
property Source: IWebBrowser2 read FSource;
published
// Published declarations
property WebObj: IWebBrowser2 read FSource;
property Connected: Boolean read FConnected;
property StatusTextChange: TIEStatusTextChangeEvent read FStatusTextChange write
FStatusTextChange;
property ProgressChange: TIEProgressChangeEvent read FProgressChange write
FProgressChange;
property CommandStateChange: TIECommandStateChangeEvent read FCommandStateChange
write FCommandStateChange;
property DownloadBegin: TIEDownloadBeginEvent read FDownloadBegin write
FDownloadBegin;
property DownloadComplete: TIEDownloadCompleteEvent read FDownloadComplete write
FDownloadComplete;
property TitleChange: TIETitleChangeEvent read FTitleChange write FTitleChange;
property PropertyChange: TIEPropertyChangeEvent read FPropertyChange write
FPropertyChange;
property BeforeNavigate2: TIEBeforeNavigate2Event read FBeforeNavigate2 write
FBeforeNavigate2;
property NewWindow2: TIENewWindow2Event read FNewWindow2 write FNewWindow2;
property NavigateComplete2: TIENavigateComplete2Event read FNavigateComplete2 write
FNavigateComplete2;
property DocumentComplete: TIEDocumentCompleteEvent read FDocumentComplete write
FDocumentComplete;
property OnQuit: TIEOnQuitEvent read FOnQuit write FOnQuit;
property OnVisible: TIEOnVisibleEvent read FOnVisible write FOnVisible;
property OnToolBar: TIEOnToolBarEvent read FOnToolBar write FOnToolBar;
property OnMenuBar: TIEOnMenuBarEvent read FOnMenuBar write FOnMenuBar;
property OnStatusBar: TIEOnStatusBarEvent read FOnStatusBar write FOnStatusBar;
property OnFullScreen: TIEOnFullScreenEvent read FOnFullScreen write FOnFullScreen;
property OnTheaterMode: TIEOnTheaterModeEvent read FOnTheaterMode write
FOnTheaterMode;
end;

// Register procedure
procedure Register;

implementation

function TIEEvents._AddRef: Integer;
begin

// No more than 2 counts
result := 2;

end;

function TIEEvents._Release: Integer;
begin
// Always maintain 1 ref count (component holds the ref count)
result := 1;
end;

function TIEEvents.QueryInterface( const IID: TGUID; out Obj): HResult;
begin
// Clear interface pointer
Pointer(Obj) := nil;

// Attempt to get the requested interface
if (GetInterface(IID, Obj)) then
// Success
result := S_OK
// Check to see if the guid requested is for the event
else if (IsEqualIID(IID, FSinkIID)) then
begin
// Event is dispatch based, so get dispatch interface (closest we can come)
if (GetInterface(IDispatch, Obj)) then
// Success
result := S_OK
else
// Failure
result := E_NOINTERFACE;
end
else
// Failure
result := E_NOINTERFACE;
end;

function TIEEvents.GetIDsOfNames( const IID: TGUID; Names: Pointer; NameCount,
LocaleID: Integer; DispIDs: Pointer): HResult;
begin
// Not implemented
result := E_NOTIMPL;
end;

function TIEEvents.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult;
begin
// Clear the result interface
Pointer(TypeInfo) := nil;
// No type info for our interface
result := E_NOTIMPL;
end;

function TIEEvents.GetTypeInfoCount(out Count: Integer): HResult;
begin
// Zero type info counts
Count := 0;
// Return success
result := S_OK;
end;

function TIEEvents.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags:
Word;
var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
var pdpParams: PDispParams;
lpDispIDs: array[0..63] of TDispID;
dwCount: Integer;
begin

// Get the parameters
pdpParams := @Params;

// Events can only be called with method dispatch, not property get/set
if ((Flags and DISPATCH_METHOD) > 0) then
begin
// Clear DispID list
ZeroMemory(@lpDispIDs, SizeOf(lpDispIDs));
// Build dispatch ID list to handle named args
if (pdpParams^.cArgs > 0) then
begin
// Reverse the order of the params because they are backwards
for dwCount := 0 to Pred(pdpParams^.cArgs) do lpDispIDs[dwCount] := Pred
(pdpParams^.cArgs) - dwCount;
// Handle named arguments
if (pdpParams^.cNamedArgs > 0) then
begin
for dwCount := 0 to Pred(pdpParams^.cNamedArgs) do lpDispIDs
[pdpParams^.rgdispidNamedArgs^[dwCount]] := dwCount;
end;
end;
// Unless the event falls into the " else " clause of the case statement the result is
S_OK
result := S_OK;
// Handle the event
case DispID of
102: DoStatusTextChange(pdpParams^.rg var g^[lpDispIds[0]].bstrval);
104: DoDownloadComplete;
105: DoCommandStateChange(pdpParams^.rg var g^[lpDispIds[0]].lval,
pdpParams^.rg var g^[lpDispIds[1]].vbool);
106: DoDownloadBegin;
108: DoProgressChange(pdpParams^.rg var g^[lpDispIds[0]].lval,
pdpParams^.rg var g^[lpDispIds[1]].lval);
112: DoPropertyChange(pdpParams^.rg var g^[lpDispIds[0]].bstrval);
113: DoTitleChange(pdpParams^.rg var g^[lpDispIds[0]].bstrval);
250: DoBeforeNavigate2(IDispatch(pdpParams^.rg var g^[lpDispIds[0]].dispval),
POleVariant(pdpParams^.rg var g^[lpDispIds[1]].p var val)^,
POleVariant(pdpParams^.rg var g^[lpDispIds[2]].p var val)^,
POleVariant(pdpParams^.rg var g^[lpDispIds[3]].p var val)^,
POleVariant(pdpParams^.rg var g^[lpDispIds[4]].p var val)^,
POleVariant(pdpParams^.rg var g^[lpDispIds[5]].p var val)^,
pdpParams^.rg var g^[lpDispIds[6]].pbool^);
251: DoNewWindow2(IDispatch(pdpParams^.rg var g^[lpDispIds[0]].pdispval^),
pdpParams^.rg var g^[lpDispIds[1]].pbool^);
252: DoNavigateComplete2(IDispatch(pdpParams^.rg var g^[lpDispIds[0]].dispval),
POleVariant(pdpParams^.rg var g^[lpDispIds[1]].p var val)^);
253:
begin
// Special case handler. When Quit is called, IE is going away so we might
// as well unbind from the interface by calling disconnect.
DoOnQuit;
// Call disconnect
Disconnect;
end;
254: DoOnVisible(pdpParams^.rg var g^[lpDispIds[0]].vbool);
255: DoOnToolBar(pdpParams^.rg var g^[lpDispIds[0]].vbool);
256: DoOnMenuBar(pdpParams^.rg var g^[lpDispIds[0]].vbool);
257: DoOnStatusBar(pdpParams^.rg var g^[lpDispIds[0]].vbool);
258: DoOnFullScreen(pdpParams^.rg var g^[lpDispIds[0]].vbool);
259: DoDocumentComplete(IDispatch(pdpParams^.rg var g^[lpDispIds[0]].dispval),
POleVariant(pdpParams^.rg var g^[lpDispIds[1]].p var val)^);
260: DoOnTheaterMode(pdpParams^.rg var g^[lpDispIds[0]].vbool);
else
// Have to idea of what event they are calling
result := DISP_E_MEMBERNOTFOUND;
end;
end
else
// Called with wrong flags
result := DISP_E_MEMBERNOTFOUND;
end;

const ructor TIEEvents.Create(AOwner: TComponent);
begin
// Perform inherited
inherited Create(AOwner);

// Set the event sink IID
FSinkIID := DWebBrowserEvents2;
end;

destructor TIEEvents.Destroy;
begin
// Disconnect
Disconnect;
// Perform inherited
inherited Destroy;
end;

procedure TIEEvents.ConnectTo(Source: IWebBrowser2);
var pvCPC: IConnectionPointContainer;
begin
// Disconnect from any currently connected event sink
Disconnect;
// Query for the connection point container and desired connection point.
// On success, sink the connection point
OleCheck(Source.QueryInterface(IConnectionPointContainer, pvCPC));
OleCheck(pvCPC.FindConnectionPoint(FSinkIID, FCP));
OleCheck(FCP.Advise(Self, FCookie));
// Update internal state var iables
FSource := Source;
// We are in a connected state
FConnected := True;
// Release the temp interface
pvCPC := nil;
end;

procedure TIEEvents.Disconnect;
begin
// Do we have the IWebBrowser2 interface?
if Assigned(FSource) then
begin
try
// Unadvise the connection point
OleCheck(FCP.Unadvise(FCookie));
// Release the interfaces
FCP := nil;
FSource := nil;
except
Pointer(FCP) := nil;
Pointer(FSource) := nil;
end;
end;

// Disconnected state
FConnected := False;
end;

procedure TIEEvents.DoStatusTextChange( const Text: WideString);
begin
// Call assigned event
if Assigned(FStatusTextChange) then FStatusTextChange(Self, Text);
end;

procedure TIEEvents.DoProgressChange(Progress: Integer; ProgressMax: Integer);
begin
// Call assigned event
if Assigned(FProgressChange) then FProgressChange(Self, Progress, ProgressMax);
end;

procedure TIEEvents.DoCommandStateChange(Command: Integer; Enable: WordBool);
begin
// Call assigned event
if Assigned(FCommandStateChange) then FCommandStateChange(Self, Command, Enable);
end;

procedure TIEEvents.DoDownloadBegin;
begin
// Call assigned event
if Assigned(FDownloadBegin) then FDownloadBegin(Self);
end;

procedure TIEEvents.DoDownloadComplete;
begin
// Call assigned event
if Assigned(FDownloadComplete) then FDownloadComplete(Self);
end;

procedure TIEEvents.DoTitleChange( const Text: WideString);
begin
// Call assigned event
if Assigned(FTitleChange) then FTitleChange(Self, Text);
end;

procedure TIEEvents.DoPropertyChange( const szProperty: WideString);
begin
// Call assigned event
if Assigned(FPropertyChange) then FPropertyChange(Self, szProperty);
end;

procedure TIEEvents.DoBeforeNavigate2( const pDisp: IDispatch; var URL: OleVariant; var
Flags:
OleVariant; var TargetFrameName: OleVariant; var PostData: OleVariant; var Headers:
OleVariant; var Cancel: WordBool);
begin
// Call assigned event
if Assigned(FBeforeNavigate2) then FBeforeNavigate2(Self, pDisp, URL, Flags,
TargetFrameName, PostData, Headers, Cancel);
end;

procedure TIEEvents.DoNewWindow2( var ppDisp: IDispatch; var Cancel: WordBool);
var
pvDisp: IDispatch;
begin
// Call assigned event
if Assigned(FNewWindow2) then
begin
if Assigned(ppDisp) then
pvDisp := ppDisp
else
pvDisp := nil;
FNewWindow2(Self, pvDisp, Cancel);
ppDisp := pvDisp;
end;
end;

procedure TIEEvents.DoNavigateComplete2( const pDisp: IDispatch; var URL: OleVariant);
begin
// Call assigned event
if Assigned(FNavigateComplete2) then FNavigateComplete2(Self, pDisp, URL);
end;

procedure TIEEvents.DoDocumentComplete( const pDisp: IDispatch; var URL: OleVariant);
begin
// Call assigned event
if Assigned(FDocumentComplete) then FDocumentComplete(Self, pDisp, URL);
end;

procedure TIEEvents.DoOnQuit;
begin
// Call assigned event
if Assigned(FOnQuit) then FOnQuit(Self);
end;

procedure TIEEvents.DoOnVisible(Visible: WordBool);
begin
// Call assigned event
if Assigned(FOnVisible) then FOnVisible(Self, Visible);
end;

procedure TIEEvents.DoOnToolBar(ToolBar: WordBool);
begin
// Call assigned event
if Assigned(FOnToolBar) then FOnToolBar(Self, ToolBar);
end;

procedure TIEEvents.DoOnMenuBar(MenuBar: WordBool);
begin
// Call assigned event
if Assigned(FOnMenuBar) then FOnMenuBar(Self, MenuBar);
end;

procedure TIEEvents.DoOnStatusBar(StatusBar: WordBool);
begin
// Call assigned event
if Assigned(FOnStatusBar) then FOnStatusBar(Self, StatusBar);
end;

procedure TIEEvents.DoOnFullScreen(FullScreen: WordBool);
begin
// Call assigned event
if Assigned(FOnFullScreen) then FOnFullScreen(Self, FullScreen);
end;

procedure TIEEvents.DoOnTheaterMode(TheaterMode: WordBool);
begin
// Call assigned event
if Assigned(FOnTheaterMode) then FOnTheaterMode(Self, TheaterMode);
end;

procedure Register;
begin
// Register the component on the Internet tab of the IDE
RegisterComponents('Internet', [TIEEvents]);
end;

end.


--- Project source ----
//Notes: Add a button and the IEEvents component to Form1. The button1 click event
// shows how the IE enumeration is achieved, and shows how the binding is done:

unit Unit1;

interface

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

type
TForm1 = class(TForm)
IEEvents1: TIEEvents;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure IEEvents1Quit(Sender: TObject);
procedure IEEvents1DownloadBegin(Sender: TObject);
procedure IEEvents1DownloadComplete(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure IEEvents1ProgressChange(Sender: TObject; Progress,
ProgressMax: Integer);
private
{ Private declarations }
FTimeList: TList;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
var
pvShell: IShellWindows;
pvWeb2: IWebBrowser2;
ovIE: OleVariant;
dwCount: Integer;
begin
// Create the shell windows interface
pvShell := CoShellWindows.Create;
// Walk the internet explorer windows
for dwCount := 0 to Pred(pvShell.Count) do
begin
// Get the interface
ovIE := pvShell.Item(dwCount);
// At this point you can evaluate the interface (LocationUrl, etc)
// to decide if this is the one you want to connect to. For demo purposes,
// the code will bind to the first one
ShowMessage(ovIE.LocationURL);
// QI for the IWebBrowser2
if (IDispatch(ovIE).QueryInterface(IWebBrowser2, pvWeb2) = S_OK) then
begin
IEEvents1.ConnectTo(pvWeb2);
// Release the interface
pvWeb2 := nil;
end;
// Clear the var iant
ovIE := Unassigned;
// Break if we connected
if IEEvents1.Connected then break;
end;
// Release the shell windows interface
pvShell := nil;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
// Create the time list
FTimeList := TList.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
// Free the time list
FTimeList.Free;
end;

procedure TForm1.IEEvents1DownloadBegin(Sender: TObject);
begin
// Add the current time to the list
FTimeList.Add(Pointer(GetTickCount));
end;

procedure TForm1.IEEvents1DownloadComplete(Sender: TObject);
var dwTime: LongWord;
begin
// Pull the top item off the list (make sure there is one)
if (FTimeList.Count > 0) then
begin
dwTime := LongWord(FTimeList[Pred(FTimeList.Count)]);
FTimeList.Delete(Pred(FTimeList.Count));
// Now calculate total based on current time
dwTime := GetTickCount - dwTime;
// Display a message showing total download time
ShowMessage(Format('Download time for "%s" was %d ms', [IEEvents1.WebObj.LocationURL,
dwTime]));
end;
end;

procedure TForm1.IEEvents1Quit(Sender: TObject);
begin
ShowMessage('About to disconnect');
end;

procedure TForm1.IEEvents1ProgressChange(Sender: TObject; Progress,
ProgressMax: Integer);
begin
Caption := IntToStr(Progress);
end;

end.