ie_events.pas

LOG monitoration of Internet Explorer navigation

unit ie_events;

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);