K210.ORG

unit Unit1;

 

interface

 

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, OleCtrls, SHDocVw;

 

type

  TForm1 = class(TForm)

    WebBrowser1: TWebBrowser;

    procedure WebBrowser1BeforeNavigate2(Sender: TObject;

      const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,

      Headers: OleVariant; var Cancel: WordBool);

    procedure FormCreate(Sender: TObject);

    procedure WebBrowser1DocumentComplete(Sender: TObject;

      const pDisp: IDispatch; var URL: OleVariant);

    procedure FormDestroy(Sender: TObject);

  private

    { Private declarations }

    FNewWndProc, FOldWndProc: Pointer;

    h: HWND;

    def:boolean;

    procedure NewWndProc(var Message: TMessage);

    procedure DefineWndProc;

 

  public

    { Public declarations }

  end;

 

var

  Form1: TForm1;

 

implementation

 

{$R *.dfm}

 

procedure TForm1.DefineWndProc;

begin

  h := GetWindow(GetWindow(WebBrowser1.Handle, GW_CHILD), GW_CHILD); // This was level 1

  FNewWndProc := Classes.MakeObjectInstance(NewWndProc);

  FOldWndProc := Pointer(GetWindowLong(h, GWL_WNDPROC));

  SetWindowLong(h, GWL_WNDPROC, Longint(FNewWndProc));

  def:=true;

end;

 

procedure TForm1.NewWndProc(var Message: TMessage);

var

  Doc,elem: oleVariant;

begin

  case Message.Msg of

    WM_LBUTTONDOWN: begin

        Doc := WebBrowser1.OleObject.document;

        try

          elem := Doc.elementFromPoint(Message.LParamLo, Message.LParamHi);

          if elem.tagName='A' then

          caption:=elem.href;

          //exit;

        except

        end;

      end;

  end;

  Message.Result := CallWindowProc(FOldWndProc, h, Message.Msg,

    Message.WParam, Message.LParam);

 

end;

 

procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject;

  const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,

  Headers: OleVariant; var Cancel: WordBool);

begin

if def then

  SetWindowLong(h, GWL_WNDPROC, Longint(FOldWndProc));

end;

 

procedure TForm1.FormCreate(Sender: TObject);

begin

  WebBrowser1.Navigate('http://yandex.ru');

end;

 

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;

  const pDisp: IDispatch; var URL: OleVariant);

begin

  DefineWndProc;

end;

 

procedure TForm1.FormDestroy(Sender: TObject);

begin

if def then

  SetWindowLong(h, GWL_WNDPROC, Longint(FOldWndProc));

end;

 

end.