HTMLDocumentEvent.pas

   1 unit HTMLDocumentEvent;
   2
   3 interface
   4
   5 uses
   6         Windows, Classes, ActiveX, ComObj;
   7
   8 type
   9         TDocumentContextMenuEvent = function(Sender: TObject): WordBool of object;
  10
  11         THTMLDocumentEventSink = class(TInterfacedObject,IUnknown,IDispatch)
  12         private
  13                 FOwner: TObject;
  14                 FSimpleDisp: IDispatch;
  15                 FSimpleIID: TGUID;
  16                 FSimpleCon: Integer;
  17                 FOnContextMenu: TDocumentContextMenuEvent;
  18         protected
  19                 { IUnknown }
  20                 function QueryInterface(const IID:TGUID; out Obj): HRESULT; stdcall;
  21                 function _AddRef:Integer; stdcall;
  22                 function _Release:Integer; stdcall;
  23                 { IDispatch }
  24                 function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
  25                 function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT; stdcall;
  26                 function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  27                         NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;
  28                 function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  29                         Flags: Word; var Params; VarResult, ExcepInfo, ArgErr:Pointer): HRESULT; stdcall;
  30         public
  31                 constructor Create(AOwner: TObject; ADisp: IDispatch; const AIID: TGUID);
  32                 destructor Destroy; override;
  33                 property OnContextMenu: TDocumentContextMenuEvent read FOnContextMenu write FOnContextMenu;
  34         end;
  35
  36 implementation
  37
  38 function THTMLDocumentEventSink._AddRef: Integer;
  39 begin
  40         Result := 2;
  41 end;
  42
  43 function THTMLDocumentEventSink._Release: Integer;
  44 begin
  45         Result := 1;
  46 end;
  47
  48 constructor THTMLDocumentEventSink.Create(AOwner: TObject; ADisp: IDispatch; const AIID: TGUID);
  49 begin
  50         inherited Create;
  51         FOwner := AOwner;
  52         FSimpleDisp := ADisp;
  53         FSimpleIID := AIID;
  54         InterfaceConnect(FSimpleDisp, FSimpleIID, Self, FSimpleCon);
  55 end;
  56
  57 destructor THTMLDocumentEventSink.Destroy;
  58 begin
  59         InterfaceDisconnect(FSimpleDisp,FSimpleIID,FSimpleCon);
  60         inherited Destroy;
  61 end;
  62
  63 function THTMLDocumentEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  64         NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;
  65 begin
  66         Result := E_NOTIMPL;
  67 end;
  68
  69 function THTMLDocumentEventSink.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT;
  70 begin
  71         Result := E_NOTIMPL;
  72 end;
  73
  74 function THTMLDocumentEventSink.GetTypeInfoCount(out Count: Integer): HRESULT;
  75 begin
  76         Count  := 0;
  77         Result := S_OK;
  78 end;
  79
  80 function THTMLDocumentEventSink.Invoke(DispID: Integer; const IID: TGUID;
  81         LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  82         ArgErr: Pointer): HRESULT;
  83 begin
  84         case DispID of
  85                 1023:
  86                         if Assigned(FOnContextMenu) then begin
  87                                 PVariant(VarResult)^ := FOnContextMenu(FOwner);
  88                         end;
  89         end;
  90         Result := S_OK;
  91 end;
  92
  93 function THTMLDocumentEventSink.QueryInterface(const IID: TGUID; out Obj): HRESULT;
  94 begin
  95         Result := E_NOINTERFACE;
  96         if GetInterface(IID,Obj) then
  97                 Result := S_OK;
  98         if IsEqualGUID(IID,FSimpleIID) and GetInterface(IDispatch,Obj) then
  99                 Result := S_OK;
 100 end;
 101
 102 end.