frmmain.pas

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

unit frmmain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  StdCtrls, ComCtrls, ExtCtrls, Buttons,shellapi,
  WebFileMan, Menus, ImgList, iniFiles, IdAntiFreeze,
  ActnList, XPStyleActnCtrls, ActnMan, ToolWin,
  ActnCtrls, ActnMenus, SUIImagePanel, Dialogs,  downthread,
  SUIButton, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient,
  IdHTTP;
type
  TstWork = (clNone, clOpenFileing, clOpenFileOk, clScanFileing, clScanFileOk,
    clDownFileIng, clStopDownFile, clDone);
const
  WM_DONE = WM_USER + 100;
type
  Tdownthread = class(TThread)
  private
    FidHTTP: TidHTTP;

    FDone: boolean;
    FcurSn: integer;
    FUrlName: string;
    FSaveFileName: string;
    FContinueDown: boolean;
    FSaveDirName: string;
    FAutoNext: boolean;
    procedure UpdateDoneInfo;
    procedure UpdateErrorInfo;
    procedure UpdateFileSizeInfo;

    { Private declarations }
  protected
    procedure Execute; override;
  public
    constructor create(SaveDirName, UrlName: string; StartSn: integer; AutoNext:
      boolean);
    destructor Destroy; override;
  end;

type
  TForm1 = class(TForm)
    dlgopen: TOpenDialog;
    dlgsave: TSaveDialog;
    Panel3: TPanel;
    suiImagePanel1: TsuiImagePanel;
    r: TRichEdit;
    imglst: TImageList;
    Panel7: TPanel;
    BtnOpen: TsuiButton;
    BtnGet: TsuiButton;
    BtnSAve: TsuiButton;
    BtnCarDownLoad: TsuiButton;
    BtnSetup: TsuiButton;
    BtnAbout: TsuiButton;
    BtnClose: TsuiButton;
    LV_Adress: TListView;
    LV_File: TListView;
    suiImagePanel2: TsuiImagePanel;
    Splitter1: TSplitter;
    Bar: TProgressBar;
    Bevel1: TBevel;
    BtnDownBegin: TsuiButton;
    BtnDownStop: TsuiButton;
    Bevel2: TBevel;
    Label1: TLabel;
    Label2: TLabel;
    stBar: TStatusBar;
    Mnu_Adress: TPopupMenu;
    D1: TMenuItem;
    C1: TMenuItem;
    A1: TMenuItem;
    N3: TMenuItem;
    S1: TMenuItem;
    E1: TMenuItem;
    T1: TMenuItem;
    ControlBar1: TControlBar;
    ActionMainMenuBar1: TActionMainMenuBar;
    ActionManager1: TActionManager;
    OpenFile: TAction;
    ExitSoft: TAction;
    GetAllImage: TAction;
    SaveToFile: TAction;
    BeginDownLoad: TAction;
    StopDownLoad: TAction;
    CarDownLoad: TAction;
    SEtup: TAction;
    AboutMe: TAction;
    Help: TAction;
    ImageList1: TImageList;
    procedure btnGetClick(Sender: TObject);
    procedure BtnSaveClick(Sender: TObject);
    procedure BtnCloseClick(Sender: TObject);
    procedure BtnSetupClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure BtnDownLoadClick(Sender: TObject);
    procedure BtnAboutClick(Sender: TObject);
    procedure BtnCarDownLoadClick(Sender: TObject);
    procedure BtnDownPauseClick(Sender: TObject);
    procedure BtnDownBeginClick(Sender: TObject);
    procedure BtnDownStopClick(Sender: TObject);
    procedure A1Click(Sender: TObject);
    procedure E1Click(Sender: TObject);
    procedure D1Click(Sender: TObject);
    procedure N3Click(Sender: TObject);

    procedure T1Click(Sender: TObject);
    procedure BtnOpenClick(Sender: TObject);
    procedure C1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);

  private
    AbortTransfer: Boolean; //是否中断
    BytesToTransfer: LongWord; //下载总大小
    ThreadList: Tstrings;
    procedure CopyAdress;
    procedure DownPic(startSn: integer; ThreadCount: integer; AutoNext:
      boolean);
    procedure DownPicEx(StartSn: integer; AutoNext: boolean);
    procedure DownAllPic;

    procedure OpenHtmFile; //添加文件
    procedure ScanHtmFile; //扫描文件提取地址
    procedure SaveAdressToFile; //保存地址文件
    procedure StopDownFile; //停止下载
    procedure DownFileByCar; //用快车下载
    procedure ShowAppSetup; //设置 参数
    procedure ShowAbout; //显示关于此软件的窗口
    procedure SetButtonSt; //设置按钮状态
    procedure AppExit; //退出
    procedure WMWorkDone(var Msg: TMessage); message WM_DONE;

    { Private declarations }
  public
    GifDown, BmpDown, JpgDown: integer;
    DefaultPicDir: string;
    DownBeginSn: integer;
    SubDirType: integer;
    TimeOutType: integer; //超时设置
    PicHadDownCount: integer; //已经下载的图片数
    PicErrorDownCount: integer; //下载错误数
    CurFileSize: integer;
    HisteryDir: Tstrings; //目录保存历史记录
    HisteryDirCount: integer;
    StWork: TstWork;
    curWorkSn: integer; // 当前下载的序号
  //  NextWorkSn:integer;//
    ThreadCount: integer; //同时下载的线程数
    NextWorkSn: integer; //
    CurThreadCount:integer;//
    procedure AddNewDir(NewDir: string);
    { Public declarations }
  end;

var
  Form1: TForm1;
  WebFileMan: TWebFileMan;
  LstFile: Tstrings;
  LstAdress: Tstrings;
 // DownFile: TmyDownFile;
  PauseSn: integer;
  SetupIni: TIniFile;
  DownThread: TDownthread;

  iCount: integer;
  PicUrl: string;
  aFile: string;
  subDirName, SaveDirName, OldDirName: string;
function GetURLFileName(aURL: string): string;
implementation
uses Ufrmsetup, UFrmAbout, UfrmSelDir, U_Pub;
{$R *.dfm}

procedure TForm1.btnGetClick(Sender: TObject);

begin
  ScanHtmFile;

end;

procedure TForm1.BtnSaveClick(Sender: TObject);
begin
  SaveAdressToFile;
end;

procedure TForm1.BtnCloseClick(Sender: TObject);
begin
  AppExit;
end;

procedure TForm1.BtnSetupClick(Sender: TObject);
begin
  ShowAppSetup;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
  tmpstr: string;
  CurrentTime: integer;
begin
  currentTime := GetTickCount div 1000;
  while ((GetTickCount div 1000) < (currentTime + 3)) do
  begin
  end;
  {不做任何事};
  WebFileMan := TWebFileMan.create(self);
  LstFile := TstringList.Create;
  LstAdress := TstringList.Create;
  HisteryDir := TstringList.create;
  ThreadList := TstringList.Create;
 // DownFile := TmyDownFile.create(self);
 // DownFile.listView := LV_Adress;
  // DefaultPicDir := 'c:\downpic';
  SetupIni := TIniFile.Create(ExtractFilePath(Paramstr(0)) + 'appsetup.ini');
  JpgDown := SetupIni.ReadInteger('Option', 'DownJpgFile', 1);
  GiFDown := SetupIni.ReadInteger('Option', 'DownGifFile', 0);
  BmpDown := SetupIni.ReadInteger('Option', 'DownBmpFile', 0);
  SubDirType := setupIni.ReadInteger('Option', 'SubDirType', 1);
  TimeOutType := SetupIni.ReadInteger('Option', 'TimeOut', 500);
  DefaultPicDir := SetupIni.ReadString('Option', 'DefaultPicDir', 'c:\downpic');
  HisteryDirCount := SetupIni.ReadInteger('Option', 'HisteryDirCount', 5);
  ThreadCount := SetupIni.ReadInteger('Option', 'ThreadCount', 5);
//  downfile.SetTimeOut(TimeOutType);
  //  for i := 1 to
  for i := 1 to HisteryDirCount do
  begin
    TmpStr := SetupIni.ReadString('Histery', 'HisteryDir' + inttostr(i), '');
    HisteryDir.Add(tmpStr);
  end;

  stWork := ClNone;
  SetButtonSt;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  i: integer;
begin

  SetupIni.WriteInteger('Option', 'JpgDown', JpgDown);
  SetupIni.WriteInteger('Option', 'GifDown', GifDown);
  SetupIni.WriteInteger('Option', 'BmpDown', BmpDown);
  SetupIni.WriteInteger('Option', 'SubDirType', SubDirType);
  SetupIni.WriteInteger('Option', 'TimeOut', TimeOutType);
  SetupIni.WriteString('Option', 'DefaultPicDir', DefaultPicDir);
  SetupIni.WriteInteger('Option', 'HisteryDirCount', HisteryDirCount);
  SetupIni.WriteInteger('Option', 'ThreadCount', ThreadCount);
  // showmessage(inttostr(HisteryDir.Count));
  for i := 1 to HisteryDir.Count do
    SetupIni.WriteString('Histery', 'HisteryDir' + inttostr(i),
      HisteryDir.Strings[i - 1]);
  SetupIni.Free;
  WebFileMan.Free;
  LstFile.Free;
  ThreadList.Free;
  LstAdress.free;
  HisteryDir.Free;
//  DownFile.Free;
end;

procedure TForm1.BtnDownLoadClick(Sender: TObject);
begin

  DownAllPic;
  //BtnDownPause.Enabled := true;
  BtnDownStop.Enabled := true;
end;

procedure TForm1.CopyAdress;
var
  TmpFileName: string;
begin
  TmpFileName := GetWinTempDir + 'WebPic.tmp';
  if FileExists(TmpFileName) then
    deleteFile(TmpFileName);
  LstAdress.SaveToFile(TmpFileName);
  R.Lines.Clear;
  R.Lines.LoadFromFile(TmpFileName);
  R.SelectAll;
  R.CopyToClipboard;
end;

procedure TForm1.BtnAboutClick(Sender: TObject);
begin
  showAbout;
end;

procedure TForm1.DownAllPic;

begin
  // DownPic(1, 3,);
end;

procedure TForm1.BtnCarDownLoadClick(Sender: TObject);
begin
  DownFileByCar;
end;

procedure TForm1.BtnDownPauseClick(Sender: TObject);
begin
  AbortTransfer := true;
  BtnDownBegin.Enabled := true;
end;

procedure TForm1.DownPic(startSn: integer; ThreadCount: integer; AutoNext:
  boolean);
var
  i: integer;

begin
  if LV_Adress.Items.Count - StartSn < ThreadCount then
    ThreadCount := LV_Adress.Items.Count - StartSn;
  for i := 1 to ThreadCount do
  begin
    SaveDirName := OldDirName;
    PicUrl := LV_Adress.Items.Item[startSn - 1].SubItems.strings[0];
    WebFileMan.WebFileName := LV_Adress.Items.Item[StartSn -
      1].SubItems.strings[1];
    if SubDirType = 1 then //用网页标题创立子文件夹
      SaveDirName := SaveDirName + CorrFileName(WebFileMan.WebTitle);
    if SubDirType = 2 then //用网页文件名创立子文件夹
      SaveDirName := SaveDirName + GetFileNameToDirName(WebFileMan.WebFileName);
    if not DirectoryExists(SaveDirName) then
      ForceDirectories(SaveDirName);
    LV_Adress.Items[startSn - 1].SubItems.strings[2] := '正在下载';
    LV_Adress.Items.Item[StartSn - 1].SubItemImages[2] := 2;
    DownThread := TDownThread.create(SaveDirName, PicUrl, StartSn, AutoNext);
    startSn := StartSn + 1;
    curThreadCount := CurThreadCount + 1;
  end;

   stWork := clDone;
  SetButtonSt;
end;

procedure TForm1.BtnDownBeginClick(Sender: TObject);
begin

  // BtnDownPause.Enabled := true;
 // BtnDownStop.Enabled := true;
 // DownPicEx(PauseSn);
end;

procedure TForm1.BtnDownStopClick(Sender: TObject);
begin
  StopDownFile;
end;

procedure TForm1.A1Click(Sender: TObject);
begin
  LV_Adress.SelectAll;
end;

procedure TForm1.E1Click(Sender: TObject);
var
  Adress: string;
begin
  if LV_Adress.SelCount = 0 then
    exit;
  Adress := LV_Adress.Selected.SubItems.Strings[0];
  ShellExecute(handle, pchar('open'), pchar(Adress), pchar(''), pchar(''),
    SW_SHOWNORMAL);

end;

procedure TForm1.D1Click(Sender: TObject);
var
  BeginSn: integer;
begin
  if LV_Adress.SelCount = 0 then
    exit;
  BeginSn := LV_Adress.Selected.Index + 1; 
 // CurWorkSn := BeginSn;
  DownPicEx(BeginSn, true);
end;

procedure TForm1.N3Click(Sender: TObject);
begin
  DownAllPic;
end;

procedure TForm1.T1Click(Sender: TObject);
begin
  LV_Adress.Clear;
end;

procedure TForm1.AddNewDir(NewDir: string);

begin

  HisteryDir.Insert(0, NewDir);
  if HisteryDir.IndexOf(NewDir) >= 0 then
    HisteryDir.Delete(HisteryDir.IndexOf(NewDir))
  else
    HisteryDir.Delete(HisteryDir.Count - 1);

end;

procedure TForm1.OpenHtmFile;
var
  i: integer;
  Fitem: TlistItem;
begin
  if dlgOpen.Execute then
  begin
    StWork := clOpenFileing;
    SetButtonSt;
    lstFile.Assign(DlgOpen.Files);
    LV_file.Clear;
    DownBeginSn := 1;
    Bar.Visible := true;
    Bar.Position := 0;
    Bar.Max := lstFile.Count;
    for i := 1 to lstFile.Count do
    begin