有了一个idhttp控件,有人说用spider我用D7没有安装成功不知道是不是版本问题,有人说用httpscan我用了,速度不行,而且使用多线程后会被mp3搜索引擎封IP(www.sogua.com就会封ip),下面是一位delphi大虾写的代码,蛮好的,就是有点小问题(得到的标题可能会是<font size=12 >阴天</font>,就是说font属性没有去掉,另外递归段的程序好像也有问题的),高手有兴趣改进一下贴上来
var
maxlayer:integer;//用于设定搜索层数(声明为全局变量)
//递归提取网页链接函数
procedure TForm1.GetLink(url:string;layer:integer);
var
source:string;
link:string;
linkText:string;
linkDir:string;
symEnd:char;
i,j:integer;
begin
source:=IdHTTP1.Get(url); //得到url的源码
try
while (Pos('<A',uppercase(source))>0) do
begin
i:=Pos('<A',uppercase(source)); //得到<A> 标记的位置
j:=Pos('</A>',uppercase(source));
//剔除<A>之前的</A>
while j<i do
begin
source[j]:='x';
j:=Pos('</A>',uppercase(source));
end;
source:='x'; //破坏当前<A>标记
//考虑原样显示标记<pre>
if (i>Pos('<PRE>',uppercase(source))) and (i<Pos('</PRE>',uppercase(source))) then
begin
continue;
end;
//判断HREF是否在<A>中
while Pos('HREF=',uppercase(source))<i do
source[Pos('HREF=',uppercase(source))]:='x';
while source<>'>' do
i:=i+1;
if i<Pos('HREF=',uppercase(source)) then
continue;
//条件成立，开始读取Link和Text
//破坏当前</A>标记
//1.读取Link
i:=Pos('HREF=',uppercase(source));
i:=i+5;
link:='';
if (source='"') or (source='''') then
begin
symEnd:=source;
i:=i+1;
end
else symEnd:=' ';
while (source<>symEnd)and (source<>'>') do
begin
link:=link+source;
i:=i+1;
end;
//2.读取Text
while source<>'>' do
i:=i+1;
i:=i+1;
linkText:='';
while i<j do
begin
linkText:=linkText+source;
i:=i+1;
end;
//保存Link和Text代码在这插入
listbox1.Items.Add(linktext);
listbox2.items.Add(link);
//***************************
//递归调用
try
if layer<MaxLayer then
begin
if (Pos('MAILTO:',uppercase(link))=0) then
begin //判断该链接是否需要递归
if Pos('HTTP://',uppercase(link))>0 then
GetLink(link,layer+1)
else
begin
linkDir:=url;
while linkDir[length(linkDir)]<>'/' do
begin
linkDir[length(linkDir)]:=' ';
linkDir:=trimright(linkDir);
end;
GetLink(linkDir+link,layer+1);
end;
end;
end;
except//对不必递归的链接进行容错
end;
end;
finally
end;
end;
]