网站网页外链检查delphi例子源代码

unit opacform1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, OleCtrls, SHDocVw,mshtml,Clipbrd, ExtCtrls,
IdBaseComponent, IdComponent, IdRawBase, IdRawClient, IdIcmpClient,Registry,IniFiles,
IdTCPConnection, IdTCPClient, IdHTTP;

type
TOPACShiYiSch = class(TForm)
IdIcmpClient1: TIdIcmpClient;
Panel2: TPanel;
WebBrowser1: TWebBrowser;
Panel1: TPanel;
WebBrowser2: TWebBrowser;
Panel3: TPanel;
Edit1: TEdit;
Edit2: TEdit;
Label1: TLabel;
Edit3: TEdit;
Edit4: TEdit;
Button1: TButton;
Splitter1: TSplitter;
Panel4: TPanel;
Memo3: TMemo;
Memo1: TMemo;
Memo2: TMemo;
IdHTTP1: TIdHTTP;
Button2: TButton;
Edit5: TEdit;
procedure Button1Click(Sender: TObject);
procedure WebBrowser1NavigateError(ASender: TObject; const pDisp: IDispatch;
const URL, Frame, StatusCode: OleVariant; var Cancel: WordBool);
procedure FormCreate(Sender: TObject);
procedure WebBrowser1NewWindow2(ASender: TObject; var ppDisp: IDispatch;
var Cancel: WordBool);
procedure WebBrowser2BeforeNavigate2(ASender: TObject;
const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
OPACShiYiSch: TOPACShiYiSch;
MainPath:string;

implementation

{$R *.dfm}

procedure TOPACShiYiSch.Button1Click(Sender: TObject);
var
s,saddress:string;
i,j,k:integer;
iall : IHTMLDocument2;
Anchors:IHTMLElementCollection;
Element:IHTMLElement;
html:string;
SL:TStringList;
found:Boolean;
MyIni:TIniFile;
begin
SL:=TStringList.Create;
if FileExists(MainPath+'skipit.ini') then
begin
MyIni:=TIniFile.Create(MainPath+'skipit.ini');
k:=1;
s:='';
while (s<>'END') do
begin
s:=MyIni.ReadString('System','key'+IntToStr(k),'END');
k:=k+1;
if (s<>'END') and (Length(s)>3) then
begin
SL.Add(s);
end;
end;
MyIni.Free;
end;

Memo1.Clear;
Memo2.Clear;
Memo3.Clear;

for j:=StrToIntDef(Edit2.Text,55000) to StrToIntDef(Edit3.Text,55000) do
begin
Caption:=IntToStr(j);
Memo3.Clear;

try
saddress:=Edit1.Text+IntToStr(j)+Edit4.Text;
WebBrowser1.Navigate(saddress);
repeat Application.ProcessMessages; until (not WebBrowser1.Busy);
Sleep(100);
except
end;

if Assigned(WebBrowser1.Document) then
begin
iall := WebBrowser1.Document AS IHTMLDocument2;

i:=0;
Anchors:=iall.links;
while i<=Anchors.Length - 1 do
begin
Element:=Anchors.item(i,varempty) as IHTMLElement;
if assigned(Element) then
begin
s:=(Element as IHTMLAnchorElement).href;
Memo3.Lines.Add(s);

if (Pos('mailto:',s)=0) and (Pos('',s)=0) and (Pos('',s)=0) and (Pos('',s)=0) and (Pos('',s)=0) and (Pos('',s)=0)
and (Pos('58.221.206.243',s)=0) and (Pos('',s)=0) and (Pos('',s)=0) and (Pos('',s)=0) and (Pos('',s)=0) and (Pos('',s)=0) and (Pos('',s)=0) and (Pos('',s)=0) and (Pos('',s)=0) and (Pos('',s)=0)
then
begin
found:=False;
for k:=0 to SL.Count-1 do
if Pos(SL[k],s)>0 then found:=True;

if not found then
begin
if Memo1.Lines.IndexOf(saddress)=-1 then Memo1.Lines.Add(saddress);
Memo2.Lines.Add(saddress);
Memo2.Lines.Add(' '+Element.innerText);
Memo2.Lines.Add(' '+s);
end;
end;

{
if Pos('http',s)=1 then
begin
try
erAgent := 'Mozilla/4.0 (compatible; MSIE 6.0; Windows 98; Maxthon)';
html:=IdHTTP1.get(s);
except
Memo2.Lines.Add(saddress);
Memo2.Lines.Add(' '+s);
end;
end;
}
end;
i:=i+1;
end;

{
iall := (WebBrowser1.Document AS IHTMLDocument2).body;
while iall.parentElement <> nil do iall := iall.parentElement;
//Memo4.Text := iall.outerHTML;

i:=0;
Anchors:=(WebBrowser1.Document AS IHTMLDocument2).Get_links;
while i<=Anchors.Length - 1 do
begin
Element:=Anchors.item(i,varempty) as IHTMLElement;
if assigned(Element) then
begin
s:=(Element as IHTMLAnchorElement).href;
Memo3.Lines.Add(s);
end;
i:=i+1;
end;
}
end;
end;

SL.Free;
end;

procedure TOPACShiYiSch.FormCreate(Sender: TObject);
begin
Set8087CW(Longword($133f));

MainPath:=ExtractFilePath(Application.ExeName);
if MainPath[length(MainPath)]<>'\' then MainPath:=MainPath+'\';
end;

procedure TOPACShiYiSch.WebBrowser1NavigateError(ASender: TObject;
const pDisp: IDispatch; const URL, Frame, StatusCode: OleVariant;
var Cancel: WordBool);
begin
Cancel:=False;
end;

procedure TOPACShiYiSch.WebBrowser1NewWindow2(ASender: TObject; var ppDisp: IDispatch;
var Cancel: WordBool);
begin
ppDisp := WebBrowser2.Application;
end;

procedure TOPACShiYiSch.WebBrowser2BeforeNavigate2(ASender: TObject;
const pDisp: IDispatch; const URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
begin
WebBrowser1.Navigate(string(URL)); // 再指回WebBrowser1
Cancel := True;
end;

procedure TOPACShiYiSch.Button2Click(Sender: TObject);
var
html:string;
begin
try
erAgent := 'Mozilla/4.0 (compatible; MSIE 6.0; W

indows 98; Maxthon)';
html:=IdHTTP1.get(Edit5.Text);
caption:='ok';
except
caption:='err';
end;
end;

end.