自己寫個從網頁裡下載圖片的程式

當你開啟某個網頁發現上面有很多好看的圖片是會怎麼辦？一個個點另存新檔？儲存網頁再慢慢處理？還是跑到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.

{========================================}