Форум программистов [Powered by Invision Power Board]

Код

program Project1;

uses
  Forms,
  SHDocVw,
  activex,
  classes,
  MSHTML,
  windows;




var wb,wb2:twebbrowser;
var stop:boolean=false;

type
 twbtr=class(tthread)
   page_url,go_url:string;
   procedure execute;override;
   procedure DocumentComplete(Sender: TObject; const pDisp: IDispatch;var URL: OleVariant);
   procedure NewWindow2(Sender: TObject; var ppDisp: IDispatch; var Cancel: WordBool);
 end;


procedure twbtr.NewWindow2(Sender: TObject; var ppDisp: IDispatch; var Cancel: WordBool);
begin
ppDisp:=wb2.ControlInterface;
end;

procedure twbtr.execute;
label sud;
begin
page_url:='http://ya.ru/';
with wb do
 begin
// Left:=screen.Width+200;                           //Раскоментировать чтобы скрыть
// Top:=screen.Height+200;                           //Раскоментировать чтобы скрыть
 showwindow(Handle,SW_SHOWNORMAL{ and SW_HIDE});     //Раскоментировать чтобы скрыть
 OnDocumentComplete:=DocumentComplete;
 OnNewWindow2:=NewWindow2;
 end;
with wb2 do
 begin
 Left:={screen.Width+}200;                          //Раскоментировать чтобы скрыть
 Top:={screen.Height+}200;                          //Раскоментировать чтобы скрыть
 showwindow(Handle,SW_SHOWNORMAL{ and SW_HIDE});    //Раскоментировать чтобы скрыть
 OnNewWindow2:=NewWindow2;
 end;
sud:
wb.Navigate(page_url);
{Если надо обработать несколько страниц - ожидаем DocumentComplete; указываем новый page_url, goto sud;
+код завершения по тамауту stop:=true }
end;

procedure twbtr.DocumentComplete(Sender: TObject; const pDisp: IDispatch;var URL: OleVariant);
var s,s1:string;
begin
if TWebBrowser(sender).DefaultInterface=pDisp as IWebBrowser then
 begin
 s:=URL;
 s1:=(TWebBrowser(sender).Document as ihtmldocument2).body.innerHTML;
 //ищем в s1 искомую сылку,сохраняем ее в  go_url, wb2.Navigate(go_url);
 //или загружаем в wb скрипт, который находит сылку и открывает ее в новом окне
 messagebox(0,pchar(s1),pchar(s),0);

 end;
end;


var wbtr:twbtr;



var msg:TMsg;
begin
//
//Здесь цикл проверки-ожидания подключения 
//

coinitialize(nil);
wb :=twebbrowser.Create(nil);
wb2:=twebbrowser.Create(nil);
wbtr:=twbtr.Create(false);
while GetMessage(msg,0,0,0)and not stop do
 begin
 translatemessage(msg);
 DispatchMessage(msg);
 end;
end.