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