IDC资讯中心
当你打开某个网页发现上面有很多好看的图片是会怎么办？一个个点另存为？保存网页再慢慢处理？还是跑到ie缓存目录里慢慢copy呢？由于我经常会遇到这样的问题，所以自己做了个程序下载网页里的图片，代码写的较烂..高手们别笑话哦。
点键击点另存为下载程序
主窗口单元：
{==========================================}
{=======================================}
{ by lanyus }
{ qq:231221 }
{ email:greathjw [at] 163.com }
{=======================================}
unit utmain;
interface
uses
windows, messages, sysutils, variants, classes, graphics, controls, forms,
dialogs, stdctrls, extctrls, buttons, idbasecomponent, idcomponent,
idtcpconnection, idtcpclient, idhttp, comctrls, psapi,shellapi,filectrl;
type
tfmmain = class(tform)
bitbtn1: tbitbtn;
le1: tlabelededit;
idhttp1: tidhttp;
statusbar1: tstatusbar;
le2: tlabelededit;
speedbutton1: tspeedbutton;
bitbtn2: tbitbtn;
pagecontrol1: tpagecontrol;
tabsheet1: ttabsheet;
tabsheet2: ttabsheet;
memo1: tmemo;
memo2: tmemo;
procedure bitbtn1click(sender: tobject);
procedure speedbutton1click(sender: tobject);
// procedure bitbtn2click(sender: tobject);
private
{ private declarations }
public
piccount,downcount:integer;
threadqty:integer;
dnqty:integer;
{ public declarations }
end;
var
fmmain: tfmmain;
implementation
uses utgetthread;
{$r *.dfm}
procedure tfmmain.bitbtn1click(sender: tobject);
var
t:tgetthread;
a:tmemorystream;
savepath:string;
begin
le1.text:=trim(le1.text);
savepath:=fmmain.le2.text;
if savepath[length(savepath)]<>/ then savepath:=savepath+/;
if not directoryexists(savepath) then
begin
try
if not forcedirectories(savepath) then
begin
showmessage(保存路径非法);
exit;
end;
except
showmessage(保存路径非法);
exit;
end;
// showmessage(保存目录不存在);
end;
piccount:=0;
downcount:=0;
memo1.clear;
t:=tgetthread.create(false);
end;
procedure tfmmain.speedbutton1click(sender: tobject);
var
dir :string;
begin
if selectdirectory(请选择保存目录,,dir) then le2.text:=dir;
end;
end.
{====================================}
下载线程单元
{===================================}
{===================================}
{ by lanyus }
{ qq:231221 }
{ email:greathjw [at] 163.com }
{===================================}
unit utgetthread;
interface
uses
windows, messages, sysutils, variants, classes, graphics, controls, forms,
dialogs, stdctrls, extctrls, buttons, idbasecomponent, idcomponent,
idtcpconnection, idtcpclient, idhttp,wininet;
type
tgetthread = class(tthread)
private
{ private declarations }
protected
idp:tidhttp;
procedure execute; override;
procedure getsrc(src:string;s:string);
function checkurl(url:string):string;
end;
// function q_posstr(const findstring, sourcestring: string; startpos: integer): integer;
implementation
uses utmain,utdownthread;
{ important: methods and properties of objects in visual components can only be
used in a method called using synchronize, for example,
synchronize(updatecaption);
and updatecaption could look like,
procedure tgetthread.updatecaption;
begin
form1.caption := updated in a thread;
end; }
{ tgetthread }
function tgetthread.checkurl(url:string):string;
var
hurl,s,s1:string;
i,a,b:integer;
begin
if url[1]=. then
begin
s:=copy(fmmain.le1.text,8,length(fmmain.le1.text)-7);
i:=pos(/,s);
a:=pos(/,url);
if i>0 then
result:=copy(fmmain.le1.text,1,i+7)+copy(url,a+1,length(url)-a)
else
result:=fmmain.le1.text+/+copy(url,a+1,length(url)-a);
exit;
end;
if url[1]=/ then
begin
s:=copy(fmmain.le1.text,8,length(fmmain.le1.text)-7);
i:=pos(/,s);
while i>0 do
begin
delete(s,1,i);
i:=pos(/,s);
end;
result:=copy(fmmain.le1.text,1,length(fmmain.le1.text)-length(s))+copy(url,2,length(url)-1);
exit;
end;
try
hurl:=uppercase(copy(url,1,4));
if hurl<>http then
begin
s:=copy(fmmain.le1.text,8,length(fmmain.le1.text)-7);
i:=pos(/,s);
if i>0 then
result:=copy(fmmain.le1.text,1,i+7)+url
else
result:=fmmain.le1.text+/+url;
end
else
result:=url;
except
result:=url;
end;
end;
procedure tgetthread.getsrc(src:string;s:string);
var
a,b:integer;
picurl,urltype:string;
download:tdownloadpic;
begin
fmmain.threadqty:=0;
a:=pos(src,s);
while a>0 do
begin
delete(s,1,a+3);
trimleft(s);
b:=pos(>,s);
if s[1]=” then
begin
delete(s,1,1);
b:=pos(“,s);
end;
if s[1]= then
begin
delete(s,1,1);
b:=pos(,s);
end;
picurl:=copy(s,1,b-1);
picurl:=stringreplace(picurl,,,[rfreplaceall]);
picurl:=trim(stringreplace(picurl,”,,[rfreplaceall]));
picurl:=checkurl(picurl);
urltype:=uppercase(stringreplace(copy(picurl,length(picurl)-3,4),.,,[rfreplaceall]));
if (pos(gif,urltype)>0) or (pos(jpg,urltype)>0) or (pos(jpeg,urltype)>0) or
(pos(png,urltype)>0) or (pos(bmp,urltype)>0) then
begin
inc(fmmain.threadqty);
download:=tdownloadpic.create(fmmain.threadqty,picurl);
fmmain.piccount:=fmmain.piccount+1;
fmmain.statusbar1.panels[0].text:=发现 +inttostr(fmmain.piccount)+ 张图片，成功下载 +inttostr(fmmain.downcount)+ 张 ;
application.processmessages;
end;
a:=pos(src,s);
end;
end;
procedure tgetthread.execute;
var
url,s:string;
//a,b,i:integer;
picurl,urltype:string;
download:tdownloadpic;
begin
freeonterminate:=true;
url:=fmmain.le1.text;
fmmain.statusbar1.panels[0].text:=正在读取+url;
try
idp:=tidhttp.create(nil);
s:=idp.get(url);
fmmain.memo2.text:=s;
fmmain.statusbar1.panels[0].text:=读取网页成功;
except
fmmain.statusbar1.panels[0].text:=读取网页失败;
fmmain.memo2.text:=;
exit;
end;
fmmain.statusbar1.panels[0].text:=正在分析图片地址，请稍候…;
//fmmain.memo2.text:=s;
s:=stringreplace(s,src,src,[rfreplaceall]);
getsrc(src=,s);
// getsrc(src=,s);
fmmain.statusbar1.panels[0].text:=分析完毕;
idp.free;
// fmmain.memo1.lines.add(s);
{ place thread code here }
end;
end.
{========================================}
