Перехват сообщений IE
01.01.2007
{
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.
Взято с сайта https://www.swissdelphicenter.ch/en/tipsindex.php