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