frmmain.pas

提取网页文件图片地址,应用此工具

      WebFileMan.WebFileName := lstFile.Strings[i - 1];
      Fitem := LV_File.Items.Add;
      Fitem.ImageIndex := 0;
      Fitem.Caption := inttostr(i);
      Fitem.SubItems.Add(WebFileMan.WebFileName);
      Fitem.SubItems.Add(WebFileMan.WebTitle);
      Fitem.SubItems.Add(inttostr(WebFileMan.PicCount));
      Bar.Position := Bar.Position + 1;
      Repaint;

    end;
  end;
  Bar.Visible := false;
  BtnGet.Enabled := true;
  stBar.Panels[3].Text := '网页文件数：' + inttostr(lstFile.Count);
  StWork := clOpenFileOk;
  SetButtonSt;
end;

procedure TForm1.BtnOpenClick(Sender: TObject);
begin

  OpenHtmFile;

end;

procedure TForm1.ScanHtmFile;
var
  i, j, PicTotal: integer;
  Fitem: TlistItem;
  AdressName, ExtName: string;
begin
  if LstFile.Count = 0 then
    exit;
  Bar.Visible := true;
  Bar.Position := 0;
  Bar.Max := lstfile.Count;
  //GrdAdress.RowCount := 2;
  LstAdress.Clear;
  PicTotal := 0;
  //  Lv_adress.Clear;

  stWork := clScanFileing;
  SetButtonSt;
  for i := 1 to LstFile.Count do
  begin
    WebFileMan.WebFileName := LstFile.Strings[i - 1];
    for j := 1 to WebFileMan.PicCount do
    begin
      LstAdress.Add(WEbFileMan.PicAdressList.Strings[j - 1]);
      Fitem := LV_Adress.Items.Add;
      //Fitem.ImageIndex := 1;
      Fitem.Caption := inttostr(PicTotal + 1);
      AdressName := WEbFileMan.PicAdressList.Strings[j - 1];
      Fitem.SubItems.Add(AdressName);
      ExtName := copy(AdressName, length(AdressName) - 2, 3);
      // showmessage(ExtName);
      if ExtName = 'jpg' then
        Fitem.ImageIndex := 15;
      if ExtName = 'bmp' then
        Fitem.ImageIndex := 14;
      if ExtName = 'gif' then
        Fitem.ImageIndex := 13;

      Fitem.SubItems.Add(WebFileMan.WebFileName);
      Fitem.SubItems.Add('未下载');
      Fitem.SubItemImages[2] := 1;
      Fitem.SubItems.Add('');
      PicTotal := PicTotal + 1;
    end;
    Bar.Position := i;
    self.Repaint;
  end;

  Bar.Visible := false;
  BtnSave.Enabled := true;
  //BtnDownload.Enabled := true;
  BtnCarDownload.Enabled := true;
  BtnDownBegin.Enabled := true;

  PauseSn := 1;
  LV_Adress.PopupMenu := Mnu_Adress;
  stBar.Panels[4].Text := '提取图片数:' + inttostr(LV_Adress.Items.Count);
  PicHadDownCount := 0;
  PicErrorDownCount := 0;
  stBar.Panels[5].Text := '已下载图片数:' + inttostr(PicHadDownCount);
  stBar.Panels[6].Text := '下载错误数:' + inttostr(PicErrorDownCount);
  stWork := clScanFileOk;
  SetButtonSt;
end;

procedure TForm1.SaveAdressToFile;
begin
  if LV_Adress.Items.Count = 0 then
  begin
    ErrorDlg('地址列表为空！', '提示');
    exit;
  end;
  if dlgsave.Execute then
    lstAdress.SaveToFile(dlgsave.FileName);
end;

procedure TForm1.StopDownFile;
begin
  AbortTransfer := true;
  stWork := clStopDownFile;
  SetButtonSt;
end;

procedure TForm1.DownFileByCar;
begin
  if FindWindow('JetCar Class', nil) = 0 then
    MessageBox(handle, '请先启动网际快车！', '使用快车下载', MB_OK or
      MB_ICONWARNING)
  else
  begin
    CopyAdress;
  end;
end;

procedure TForm1.ShowAppSetup;
begin
  Application.CreateForm(TfrmSetup, FrmSetup);
  FrmSetup.ChkJpg.Checked := WebFileMan.JpgDown;
  FrmSetup.ChkBmp.Checked := WebFileMan.BmpDown;
  FrmSetup.ChkGif.Checked := WebFileMan.GifDown;
  if SubDirType = 1 then
    FrmSetup.RBtn_TitleDir.Checked := true;
  if SubDirType = 2 then
    FrmSetup.Rbtn_FileDir.Checked := true;
  if SubDirType = 3 then
    FrmSetup.RBtn_NoDir.Checked := true;
  FrmSetup.Edt_TimeOut.Text := inttostr(TimeOutType);
  frmSetup.edt_folder.Text := DefaultPicDir;
  frmSetup.Edt_HisteryDirCount.Text := inttostr(HisteryDirCount);
  frmSetup.Edt_ThreadCount.Text := inttostr(ThreadCount);
  frmSetup.ShowModal;
end;

procedure TForm1.ShowAbout;
begin
  Application.CreateForm(TfrmAbout, FrmAbout);
  FrmAbout.ShowModal;
end;

procedure TForm1.AppExit;
begin

  close;
end;

procedure TForm1.SetButtonSt;
begin
  if stWork = clNone then
  begin
    BtnOpen.Enabled := true;
    BtnGet.Enabled := false;
    BtnSave.Enabled := false;
    BtnDownBegin.Enabled := false;
    BtnDownStop.Enabled := false;
    BtnCarDownLoad.Enabled := false;
  end;
  if stWork = clOpenFileing then
  begin
    BtnOpen.Enabled := false;
    BtnGet.Enabled := false;
    BtnSave.Enabled := false;
    BtnDownBegin.Enabled := false;
    BtnDownStop.Enabled := false;
    BtnCarDownLoad.Enabled := false;
  end;
  if StWork = clOpenFileOk then
  begin
    BtnOpen.Enabled := true;
    BtnGet.Enabled := true;
    BtnSave.Enabled := false;
    BtnDownBegin.Enabled := false;
    BtnDownStop.Enabled := false;
    BtnCarDownLoad.Enabled := false;
  end;
  if StWork = clScanFileing then
  begin
    BtnOpen.Enabled := false;
    BtnGet.Enabled := false;
    BtnSave.Enabled := false;
    BtnDownBegin.Enabled := false;
    BtnDownStop.Enabled := false;
    BtnCarDownLoad.Enabled := false;
  end;
  if StWork = clScanFileOk then
  begin
    BtnOpen.Enabled := true;
    BtnGet.Enabled := true;
    BtnSave.Enabled := true;
    BtnDownBegin.Enabled := true;
    BtnDownStop.Enabled := false;
    BtnCarDownLoad.Enabled := true;
  end;
  if StWork = clDownFileing then
  begin
    BtnOpen.Enabled := false;
    BtnGet.Enabled := false;
    BtnSave.Enabled := true;
    BtnDownBegin.Enabled := false;
    BtnDownStop.Enabled := true;
    BtnCarDownLoad.Enabled := true;
  end;
  if StWork = clStopDownFile then
  begin
    BtnOpen.Enabled := true;
    BtnGet.Enabled := true;
    BtnSave.Enabled := true;
    BtnDownBegin.Enabled := true;
    BtnDownStop.Enabled := false;
    BtnCarDownLoad.Enabled := true;
  end;
  if stWork = clDone then
  begin
    BtnOpen.Enabled := true;
    BtnGet.Enabled := true;
    BtnSave.Enabled := true;
    BtnDownBegin.Enabled := true;
    BtnDownStop.Enabled := false;
    BtnCarDownLoad.Enabled := true;
  end;

end;

procedure TForm1.C1Click(Sender: TObject);
begin
  if LV_Adress.SelCount = 0 then
    exit;
end;

procedure TForm1.WMWorkDone(var Msg: TMessage);
begin
  if NextWorkSn = LV_Adress.Items.Count + 1 then
    exit;
  NExtWorkSn := NextWorkSn + 1;
  //  DownFile.Free ;
   //infodlg('work done','',1);
  //label3.Caption := '线程数：' + inttostr(ThreadList.Count);
  DownPic(NextWorkSn, 1, true);
end;

procedure TForm1.DownPicEx(StartSn: integer; AutoNext: boolean);
begin
  if (LV_Adress.Items.Count = 0) or (StartSn > LV_Adress.Items.Count) then
    exit;
  Application.CreateForm(TfrmSelDir, FrmSelDir);
  FrmSelDir.edt_folder.Text := DefaultPicDir;

  if FrmSelDir.ShowModal = mrOk then
  begin
    OldDirName := FrmSelDir.edt_folder.Text;

    AddNewDir(OldDirName);

  end
  else
    exit;

  AbortTransfer := false;
  Bar.Visible := true;
  stWork := clDownFileing;
  SetButtonSt;
  for iCount := StartSn to lstAdress.Count do //变等待下载图标
  begin
    LV_Adress.Items.Item[iCount - 1].SubItemImages[2] := 5;
    LV_Adress.Items.Item[iCount - 1].SubItems.strings[2] := '等待下载';
  end;
  DownPic(StartSn, ThreadCount, AutoNext);
  NextWorksn := StartSn +  ThreadCount - 1;
end;

{ Tdownthread }

constructor Tdownthread.create(SaveDirName, UrlName: string; StartSn: integer;
  AutoNext: boolean);
begin
  inherited create(false);
  FurlName := UrlName;
  FSaveDirName := SaveDirName;
  FSaveFileName := SaveDirName + '\' + GetUrlFileName(FurlName) + '.!';

  FAutoNext := AutoNext;
  if FileExists(FSaveFileName) then
    deleteFile(FsaveFileName);
  FcurSn := StartSn;
  FidHTTP := TidHTTP.Create(nil);
  FidHTTP.ReadTimeout := form1.TimeOutType;
  
end;

destructor Tdownthread.Destroy;
begin
  FIdHTTP.Free;
  //  showmessage(inttostr(form1.curThreadcount));
  Form1.CurThreadCount := form1.CurThreadCount - 1;
  inherited;
end;

procedure Tdownthread.Execute;
var
  FileSize, i, BlockNum, lestSize: integer;
 FFileStream:TFileStream;
  BufferSize: integer;

begin
  inherited;
  try
    FDone := false;
    FFileStream := TFileStream.Create(FSaveFileName, fmCreate);
    FidHTTP.Head(FUrlName);
    FileSize := FIdHTTP.Response.ContentLength;
    BufferSize := FidHTTP.RecvBufferSize;
    if BufferSize >= FileSize then
      FidHTTP.Get(FUrlName, FFileStream)
    else
       begin
        BlockNum := FileSize div BufferSize;
        if BlockNum > 0 then
          for i := 1 to BlockNum do
          begin
            FIdHTTP.Request.ContentRangeStart := FFileStream.Size - 1;
            FFileStream.Position := FFileStream.Size - 1; //移动到最后继续下载
            FIdHTTP.Request.ContentRangeEnd := BufferSize * i;
            FidHTTP.Get(FUrlName, FFileStream);
            Form1.LV_Adress.Items.Item[FcurSn - 1].SubItems.strings[3] :=
              inttostr(FFileStream.Size div 1024) + 'K';
          end;
        LestSize := FileSize - BufferSize * BlockNum;
        if LestSize > 0 then
        begin
          FIdHTTP.Request.ContentRangeStart := FFileStream.Size - 1;
          FFileStream.Position := FFileStream.Size - 1; //移动到最后继续下载
          FIdHTTP.Request.ContentRangeEnd := FileSize;
          FidHTTP.Get(FUrlName, FFileStream);
        end;

      end;
          Form1.LV_Adress.Items.Item[FcurSn - 1].SubItems.strings[3] :=
              inttostr(FFileStream.Size div 1024) + 'K';

       FFileStream.Free;
       FidHTTP.Disconnect;
      RenameFile(FSaveFileName, copy(FSaveFileName, 0, length(FSaveFileName) -
        2));
           Synchronize(UpdateDoneInfo);
  except
    if (FFileStream.Size = FileSize) then
    begin

      FFileStream.Free;
      RenameFile(FSaveFileName, copy(FSaveFileName, 0, length(FSaveFileName) -
        2));
            Synchronize(UpdateDoneInfo);
    end;
    if FFileStream.Size = 0 then
    begin
    
      FFileStream.Free;
      deleteFile(FSaveFileName);
        Synchronize(UpdateErrorInfo);
    end;
     FidHTTP.Disconnect; 
  end;
end;

procedure Tdownthread.UpdateDoneInfo;
begin
  form1.LV_Adress.Items.Item[FCurSn - 1].SubItems.Strings[2] := '下载成功';
  form1.LV_Adress.Items.Item[FCurSn - 1].SubItemImages[2] := 4;
  if FAutoNext then
    sendmessage(form1.Handle, WM_DONE, 0, 0);

end;

procedure Tdownthread.UpdateErrorInfo;
begin
  form1.LV_Adress.Items.Item[FCurSn - 1].SubItems.Strings[2] := '下载失败';
  form1.LV_Adress.Items.Item[FCurSn - 1].SubItemImages[2] := 3;
  if FAutoNext then
    sendmessage(form1.Handle, WM_DONE, 0, 0);
end;

/////////////////////////////////

function GetURLFileName(aURL: string): string;
var
  i: integer;
  s: string;
begin //返回下载地址的文件名
  s := aURL;
  i := Pos('/', s);
  while i <> 0 do //去掉"/"前面的内容剩下的就是文件名了
  begin
    Delete(s, 1, i);
    i := Pos('/', s);
  end;
  // showmessage('下载文件名:' + s);
  Result := s;
end;
///////////////////////////////////
procedure Tdownthread.UpdateFileSizeInfo;
begin

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  showmessage(inttostr(curThreadcount));
end;

end.