Intercept IE Messages

Das folgende Beispiel demonstriert uns, wie Nachrichten über den Internet Explorer abgefangen werden können.

Um den Code zum Laufen zu bringen, müssen einige Handgriffe getan werden.

Die "IEEvents.pas" Datei muss in den Compiler installiert werden. Sie wird in der Komponentenleiste unter "Internet" abgelegt.

In der Unit1 werden dann die OnEvents..

• IEEvents1DownloadBegin
• IEEvents1Quit
• IEEvents1ProgressChange
• IEEvents1DocumentComplete

..genutzt, denen die entsprechenden Code abschnitte hinzugefügt werden müssen.

Unit IEEvents.pas

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.

Unit1 :

uses IEEvents, ActiveX, SHDocVw

private
    { Private declarations }
    FTimeList: TList;
    
//

procedure TForm1.IEEvents1DownloadBegin(Sender: TObject);
begin
  // Add the current time to the list
  FTimeList.Add(Pointer(GetTickCount));
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;

procedure TForm1.IEEvents1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
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.FormCreate(Sender: TObject);
begin
  // Create the time list
  FTimeList := TList.Create;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  // Free the time list
  FTimeList.Free;
end;

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;