Главная » Delphi » Интернет и сети » подмена оконной процедуры TWebBrowser

подмена оконной процедуры TWebBrowser

18:08
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.