Прерывать сообщения Internet Explorer

Советы » Браузер » Прерывать сообщения 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 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

.

Другое по теме:

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com