5、利用控件TVCLZip和TIdFTP压缩文件并上传到FTP的线程单元pas

{*******************************************************************************
  Copyright (C), 2014-2020, aicaipiao
  File name: UFtpContentThd.pas
  Author: lipingchen
  Version:
  Date:  20140929
  Description:
  Others:
  Function List:
    解压缩文件
    FTP遍历创建新目录
    定时
*******************************************************************************}
unit UFtpContentThd;

interface

uses
  Classes,Forms,Dialogs,SysUtils,Windows,VCLZip,VCLUnZip,IdFTP,IdFTPList,IdFTPListParseWindowsNT,IdAllFTPListParsers;

type

  TFtpContentThd = class(TThread)
  private

  protected
    ziper:TVCLZip;
    IdFTP: TIdFTP;

    Filename:string;  //生成压缩文件名
    FMessage: string;  //消息
    ZipUpLoadDir,ZipUpLoadDirTemp:string;  //上传FTP的路径
    FDeptID:string;  //出票点ID
  public
    constructor Create;
    destructor  Destroy;override;
    function CreatFtpDir(UpLoadDir:string): Boolean;  //遍历当前FTP文件夹， 创建新目录或更改路径
    
    //用法：Zip(压缩模式，压缩包大小，压缩或解压文件，解压或压缩目录，TVCLZip控件)
    //ZipMode为0：压缩；为1：解压缩　PackSize为0则不分包；否则为分包的大小
    function Zip(ZipMode,packSize:Integer;ZipFile,UnzipDir:string):Boolean;
  protected
    procedure Execute; override;
  end;

var
   FtpContentThd:TFtpContentThd;
implementation
uses
  UPubTypeVarCon;

{ TFtpContentThd }

constructor TFtpContentThd.Create;
begin
  if not DirectoryExists(pub_ZipFileSaveDir) then  //压缩包保存路径
    CreateDir(pub_ZipFileSaveDir);
  try
    inherited Create(True);
    FreeOnTerminate := True;
    Resume;

    FDeptID:='6';
    ziper:=TVCLZip.Create(nil);
    IdFTP:=TIdFTP.Create;
    LogMsg('创建FTP上传线程成功!',true,true);
  except
    on e:exception do
    begin
      FMessage:='创建FTP上传线程出错!'#13+e.Message;
      LogMsg(FMessage,true,true);
    end;
  end;
end;

procedure TFtpContentThd.Execute;
begin
  while not Terminated do
  begin
    Filename:=FormatDateTime('yyyy',Now)+'.'+FDeptID+'.'+FormatDateTime('mmddhhnnss',Now)+'.zip';
    ZipUpLoadDir:=FormatDateTime('yyyy',Now)+'\'+FDeptID+'\'+FormatDateTime('mm',Now)
     +'\'+FormatDateTime('dd',Now)+'\'+FormatDateTime('hh',Now);

    if not Zip(0,0,pub_ZipFileSaveDir+'\'+Filename,pub_UnZipFileSaveDir) then  //将abc.zip解压到路径，若不存在会自动创建目录的。
    begin
     //执行失败
     Sleep(pub_FtpExecInterval * 1000);  //等待一下
     Continue;   // exit；
    end;
    //发送
    with IdFTP do
    begin
      if not Connected then
      begin
        Username:=pub_FtpUsername;
        Password:=pub_FtpPassword;
        try
          Connect(pub_FtpHost,pub_FtpPort);

        except
          on e:exception do
          begin
            FMessage:='连接FTP服务器出错!'#13+e.Message;
            LogMsg(FMessage,true,true);
            Break;
          end;
        end;
      end;
      if Connected then
      begin
        if ZipUpLoadDirTemp<>ZipUpLoadDir  then  //上传保存的路径改变，则创建新目录或更改路径。
        begin
          ChangeDir(pub_ZipUpLoadRtDir);  //先回到设定的根目录
          CreatFtpDir(ZipUpLoadDir);
        end;
        try
          Put(pub_ZipFileSaveDir+'\'+Filename,Filename);
          Sleep(pub_FtpExecInterval * 1000);  //等待中
          deletefile(PChar(pub_ZipFileSaveDir+'\'+Filename)); //删除已上传的文件
        except
          on e:exception do
          begin
            FMessage:='文件上传FTP服务器出错!'#13+e.Message;
            LogMsg(FMessage,true,true);
            Continue;
          end;
        end;
      end;
    end;
    ZipUpLoadDirTemp:=ZipUpLoadDir;

  end;
end;

function TFtpContentThd.Zip(ZipMode, packSize: Integer; ZipFile,
  UnzipDir: string): Boolean;
begin
  if copy(UnzipDir,length(UnzipDir),1)='\'then
      UnzipDir:=copy(UnzipDir,1,length(UnzipDir)-1);//去除目录后的'\'
  try
    ziper.DoAll:=False;//加此设置将对分包文件解压缩无效
    ziper.OverwriteMode:=Always;//总是覆盖模式

    if PackSize<>0then    //0则压缩成一个文件，否则压成多文件
    begin
      ziper.MultiZipInfo.MultiMode:=mmBlocks;//设置分包模式
      ziper.MultiZipInfo.SaveZipInfoOnFirstDisk:=True;//打包信息保存在第一文件中
      ziper.MultiZipInfo.FirstBlockSize:=PackSize;//分包首文件大小
      ziper.MultiZipInfo.BlockSize:=PackSize;//其他分包文件大小
    end;
    ziper.FilesList.Clear;
    ziper.ZipName:=ZipFile;//获取压缩文件名
    if ZipMode=0then  //压缩
    begin
      ziper.FilesList.Add(UnzipDir+'\*.txt');  //添加压缩文件列表   设定为|*.txt文档，若需压缩全部可\*.*
      Application.ProcessMessages;
      ziper.Zip;
    end else
    begin
      ziper.DestDir:=UnzipDir;//解压缩的目标目录
      ziper.UnZip;           //解压缩
    end;
    Result:=True;
  except
   on ex:exception do
   begin
     Result:=False;
     FMessage := '文件解压缩异常'#13 + ex.Message;
     LogMsg(FMessage,True,True);
   end;
  end;
end;

function TFtpContentThd.CreatFtpDir(UpLoadDir: string): Boolean;
var
  CreatDirList: TStringList;
  //DirList:TStringList;
  i,j,flag:Integer;
begin
  CreatDirList:=TStringList.Create;
  //DirList:=TStringList.Create;
  CreatDirList.Delimiter :='\';
  CreatDirList.DelimitedText :=UpLoadDir;
  for i := 0 to CreatDirList.Count - 1 do
  begin
    if CreatDirList[i]<>'' then
    begin
      flag:=0;
      IdFTP.List;
      //ShowMessage(IntToStr(IdFTP.DirectoryListing.Count));  //默认uses idftplistParse异常；要添加IdFTPListParseWindowsNT,IdAllFTPListParsers单元
      for j := 0  to IdFTP.DirectoryListing.Count-1 do        //indy10要添加IdFTPListParseWindowsNT,IdAllFTPListParsers单元
      begin                                                   //介绍：http://blog.sunshow.net/2007/07/tidftp-directorylisting-usage/
        if IdFTP.DirectoryListing.Items[j].ItemType = ditDirectory then   //要添加单元IdFTPList
        begin
          if IdFTP.DirectoryListing.Items[j].FileName = CreatDirList[i] then
          begin
            flag:=1;  //标志已经存在该目录
            Break;
          end;
        end;
      end;
      if flag=0 then
        IdFTP.MakeDir(CreatDirList[i]);  //新创建文件夹

      IdFTP.ChangeDir(CreatDirList[i]);  //更改目录
    end;

    //***以下DirList内容有空格,IndexOf(CreatDirList[i])识别不了；也不严谨***
   { if CreatDirList[i]<>'' then
    begin
      IdFTP.List(DirList,'',True);
      if (DirList.IndexOf(CreatDirList[i])=-1) then
      begin
        try
          IdFTP.MakeDir(CreatDirList[i]);
        except on ex:Exception do
          LogMsg('添加目录名:'+CreatDirList[i]+'出错,原因：'+ex.Message,True,True );
        end;
        try
          IdFTP.ChangeDir(CreatDirList[i]);
        except on ex:Exception do
          LogMsg('变更目录名:'+CreatDirList[i]+'出错,原因：'+ex.Message,True,True );
        end;
      end;
    end; }

    //***以下忽略异常，懒虫写法，***
   { try
      IdFTP.ChangeDir(CreatDirList[i]);
    except
      IdFTP.MakeDir(CreatDirList[i]);
      IdFTP.ChangeDir(CreatDirList[i]);
    end;}

    //***以下忽略异常，懒虫写法，***
   { try
      IdFTP.MakeDir(CreatDirList[i]);
    finally
      IdFTP.ChangeDir(CreatDirList[i]);
    end;   }

  end;
  Result :=True;
end;

destructor TFtpContentThd.Destroy;
begin
  //inherited; //继承会产生异常  为什么？？
  ziper.Free;
  IdFTP.Free;
  try
    FtpContentThd.Terminate;
    WaitForSingleObject(FtpContentThd.Handle, 500);
    FtpContentThd := nil;
  except on ex:Exception do
    begin
    end;
  end;
  //
  LogMsg('FTP上传线程终止',False,true);
end;

initialization
   //
finalization
  //
end.