当你打开某个网页发现上面有很多好看的图片是会怎么办？一个个点另存为？保存网页再慢慢处理？还是跑到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;
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.
{========================================}
