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                 FOnClick: TDocumentContextMenuEvent;
  19                 FOnMouseMove: TDocumentContextMenuEvent;
  20         protected
  21                 { IUnknown }
  22                 function QueryInterface(const IID:TGUID; out Obj): HRESULT; stdcall;
  23                 function _AddRef:Integer; stdcall;
  24                 function _Release:Integer; stdcall;
  25                 { IDispatch }
  26                 function GetTypeInfoCount(out Count: Integer): HRESULT; stdcall;
  27                 function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT; stdcall;
  28                 function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  29                         NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;
  30                 function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  31                         Flags: Word; var Params; VarResult, ExcepInfo, ArgErr:Pointer): HRESULT; stdcall;
  32         public
  33                 constructor Create(AOwner: TObject; ADisp: IDispatch; const AIID: TGUID);
  34                 destructor Destroy; override;
  35                 property OnContextMenu: TDocumentContextMenuEvent read FOnContextMenu write FOnContextMenu;
  36                 property OnClick: TDocumentContextMenuEvent read FOnClick write FOnClick;
  37                 property OnMouseMove: TDocumentContextMenuEvent read FOnMouseMove write FOnMouseMove;
  38         end;
  39
  40 implementation
  41
  42 function THTMLDocumentEventSink._AddRef: Integer;
  43 begin
  44         Result := 2;
  45 end;
  46
  47 function THTMLDocumentEventSink._Release: Integer;
  48 begin
  49         Result := 1;
  50 end;
  51
  52 constructor THTMLDocumentEventSink.Create(AOwner: TObject; ADisp: IDispatch; const AIID: TGUID);
  53 begin
  54         inherited Create;
  55         FOwner := AOwner;
  56         FSimpleDisp := ADisp;
  57         FSimpleIID := AIID;
  58         InterfaceConnect(FSimpleDisp, FSimpleIID, Self, FSimpleCon);
  59 end;
  60
  61 destructor THTMLDocumentEventSink.Destroy;
  62 begin
  63         InterfaceDisconnect(FSimpleDisp,FSimpleIID,FSimpleCon);
  64         inherited Destroy;
  65 end;
  66
  67 function THTMLDocumentEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  68         NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT;
  69 begin
  70         Result := E_NOTIMPL;
  71 end;
  72
  73 function THTMLDocumentEventSink.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HRESULT;
  74 begin
  75         Result := E_NOTIMPL;
  76 end;
  77
  78 function THTMLDocumentEventSink.GetTypeInfoCount(out Count: Integer): HRESULT;
  79 begin
  80         Count  := 0;
  81         Result := S_OK;
  82 end;
  83
  84 function THTMLDocumentEventSink.Invoke(DispID: Integer; const IID: TGUID;
  85         LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  86         ArgErr: Pointer): HRESULT;
  87 begin
  88         case DispID of
  89     DISPID_MOUSEMOVE:
  90                         if Assigned(FOnMouseMove) then begin
  91                                 PVariant(VarResult)^ := FOnMouseMove(FOwner);
  92       end;
  93     DISPID_CLICK:
  94                         if Assigned(FOnClick) then begin
  95                                 PVariant(VarResult)^ := FOnClick(FOwner);
  96       end;
  97                 1023:
  98                         if Assigned(FOnContextMenu) then begin
  99                                 PVariant(VarResult)^ := FOnContextMenu(FOwner);
 100                         end;
 101         end;
 102         Result := S_OK;
 103 end;
 104
 105 function THTMLDocumentEventSink.QueryInterface(const IID: TGUID; out Obj): HRESULT;
 106 begin
 107         Result := E_NOINTERFACE;
 108         if GetInterface(IID,Obj) then
 109                 Result := S_OK;
 110         if IsEqualGUID(IID,FSimpleIID) and GetInterface(IDispatch,Obj) then
 111                 Result := S_OK;
 112 end;
 113
 114 end.