How to draw something over WebBrowser component in Delphi

Question

Is it possible to draw or put something over the WebBrowser component to draw on it ?
When I add an image on WebBrowser this image is always under the WebBrowser. I need this to draw area over different map types always in the same way. For example I need to draw the same area on Google Maps and open street maps...

Answer 1

You should use IHTMLPainter.Draw event method for doing this. The following code needs a TWebBrowser where you have to write the OnDocumentComplete event handler.

Note that this example has one big weakness, the user input events like mouse clicking are active because the only thing what this example do is the painting over the element. I've been playing with this a little bit, but without success. This might be a good topic for another question.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  StdCtrls, SHDocVw, MSHTML, OleCtrls;

type
  TElementBehavior = class(TInterfacedObject, IElementBehavior, IHTMLPainter)
  private
    FPaintSite: IHTMLPaintSite;
  public
    { IElementBehavior }
    function Init(const pBehaviorSite: IElementBehaviorSite): HRESULT; stdcall;
    function Notify(lEvent: Integer; var pVar: OleVariant): HRESULT; stdcall;
    function Detach: HRESULT; stdcall;
    { IHTMLPainter }
    function Draw(rcBounds: tagRECT; rcUpdate: tagRECT; lDrawFlags: Integer;
      hdc: hdc; pvDrawObject: Pointer): HRESULT; stdcall;
    function OnResize(size: tagSIZE): HRESULT; stdcall;
    function GetPainterInfo(out pInfo: _HTML_PAINTER_INFO): HRESULT; stdcall;
    function HitTestPoint(pt: tagPOINT; out pbHit: Integer; out plPartID: Integer): HRESULT; stdcall;
  end;

  TElementBehaviorFactory = class(TInterfacedObject, IElementBehaviorFactory)
  public
    function FindBehavior(const bstrBehavior: WideString;
      const bstrBehaviorUrl: WideString; const pSite: IElementBehaviorSite;
      out ppBehavior: IElementBehavior): HRESULT; stdcall;
  end;

  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure WebBrowser1DocumentComplete(ASender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  Image: TBitmap;
  Behavior: TElementBehavior;
  Factory: TElementBehaviorFactory;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Image := TBitmap.Create;
  Image.LoadFromFile('c:\yourpicture.bmp');
  WebBrowser1.Navigate('maps.google.com');
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Behavior := nil;
  Factory := nil;
  Image.Free;
end;

procedure TForm1.WebBrowser1DocumentComplete(ASender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  HTMLElement: IHTMLElement2;
  FactoryVariant: OleVariant;
begin
  HTMLElement := (WebBrowser1.Document as IHTMLDocument3).getElementById('map') as IHTMLElement2;

  if Assigned(HTMLElement) then
  begin
    Behavior := TElementBehavior.Create;
    Factory := TElementBehaviorFactory.Create;
    FactoryVariant := IElementBehaviorFactory(Factory);
    HTMLElement.addBehavior('', FactoryVariant);
  end;
end;

function TElementBehaviorFactory.FindBehavior(const bstrBehavior,
  bstrBehaviorUrl: WideString; const pSite: IElementBehaviorSite;
  out ppBehavior: IElementBehavior): HRESULT;
begin
  ppBehavior := Behavior;
  Result := S_OK;
end;

function TElementBehavior.Draw(rcBounds: tagRECT; rcUpdate: tagRECT; lDrawFlags: Integer;
  hdc: hdc; pvDrawObject: Pointer): HRESULT;
begin
  StretchBlt(
    hdc,
    rcBounds.Left,
    rcBounds.Top,
    rcBounds.Right - rcBounds.Left,
    rcBounds.Bottom - rcBounds.Top,
    Image.Canvas.Handle,
    0,
    0,
    Image.Canvas.ClipRect.Right - Image.Canvas.ClipRect.Left,
    Image.Canvas.ClipRect.Bottom - Image.Canvas.ClipRect.Top,
    SRCCOPY);
  Result := S_OK; 
end;

function TElementBehavior.GetPainterInfo(out pInfo: _HTML_PAINTER_INFO): HRESULT;
begin
  pInfo.lFlags := HTMLPAINTER_OPAQUE;
  pInfo.lZOrder := HTMLPAINT_ZORDER_WINDOW_TOP;
  FillChar(pInfo.rcExpand, SizeOf(TRect), 0);
  Result := S_OK;
end;

function TElementBehavior.HitTestPoint(pt: tagPOINT; out pbHit,
  plPartID: Integer): HRESULT;
begin
  Result := E_NOTIMPL;
end;

function TElementBehavior.OnResize(size: tagSIZE): HRESULT;
begin
  Result := S_OK;
end;

function TElementBehavior.Detach: HRESULT;
begin
  if Assigned(FPaintSite) then
    FPaintSite.InvalidateRect(nil);
  Result := S_OK;
end;

function TElementBehavior.Init(
  const pBehaviorSite: IElementBehaviorSite): HRESULT;
begin
  Result := pBehaviorSite.QueryInterface(IHTMLPaintSite, FPaintSite);
  if Assigned(FPaintSite) then
    FPaintSite.InvalidateRect(nil);
end;

function TElementBehavior.Notify(lEvent: Integer;
  var pVar: OleVariant): HRESULT;
begin
  Result := E_NOTIMPL;
end;

end.