...intercept Internet Explorer messages?

Author: rllibby
Homepage: http://www.experts-exchange.com/Programming/Programming_Languages/Delphi/Q_20850691.html

Category: Internet / LAN

{
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; virtualstdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtualstdcall;
    function GetTypeInfoCount(out Count: Integer): HResult; virtualstdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; virtualstdcall;
     // 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.

 

printed from
www.swissdelphicenter.ch
developers knowledge base