Перехват сообщений IE

{
This component allows you to intercept Internet Explorer messages such as
"StatusTextChangeEvent", "DocumentCompleteEvent" and so on.
}
//---- 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
 constructor 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^.rgvarg^[lpDispIds[0]].bstrval);
 104: DoDownloadComplete;
 105: DoCommandStateChange(pdpParams^.rgvarg^[lpDispIds[0]].lval,
 pdpParams^.rgvarg^[lpDispIds[1]].vbool);
 106: DoDownloadBegin;
 108: DoProgressChange(pdpParams^.rgvarg^[lpDispIds[0]].lval,
 pdpParams^.rgvarg^[lpDispIds[1]].lval);
 112: DoPropertyChange(pdpParams^.rgvarg^[lpDispIds[0]].bstrval);
 113: DoTitleChange(pdpParams^.rgvarg^[lpDispIds[0]].bstrval);
 250: DoBeforeNavigate2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval),
 POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^,
 POleVariant(pdpParams^.rgvarg^[lpDispIds[2]].pvarval)^,
 POleVariant(pdpParams^.rgvarg^[lpDispIds[3]].pvarval)^,
 POleVariant(pdpParams^.rgvarg^[lpDispIds[4]].pvarval)^,
 POleVariant(pdpParams^.rgvarg^[lpDispIds[5]].pvarval)^,
 pdpParams^.rgvarg^[lpDispIds[6]].pbool^);
 251: DoNewWindow2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].pdispval^),
 pdpParams^.rgvarg^[lpDispIds[1]].pbool^);
 252: DoNavigateComplete2(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval),
 POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^);
 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^.rgvarg^[lpDispIds[0]].vbool);
 255: DoOnToolBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool);
 256: DoOnMenuBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool);
 257: DoOnStatusBar(pdpParams^.rgvarg^[lpDispIds[0]].vbool);
 258: DoOnFullScreen(pdpParams^.rgvarg^[lpDispIds[0]].vbool);
 259: DoDocumentComplete(IDispatch(pdpParams^.rgvarg^[lpDispIds[0]].dispval),
 POleVariant(pdpParams^.rgvarg^[lpDispIds[1]].pvarval)^);
 260: DoOnTheaterMode(pdpParams^.rgvarg^[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;
constructor 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 variables
 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 variant
 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.
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03517
Category:Связь
Category:WebBrowser