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

用到临界区 保护写日志的函数；

递归函数 删除目录下的所有文件；

循环创建或判断FTP的目录；

可改进的地方：循环压缩深层次目录的所以文件； 实现断点续传，或断点下载；

 {*******************************************************************************
   Copyright (C), 2014-2020, aicaipiao
   File name: UFtpContentThd.pas
   Author: lipingchen
   Version:
   Date:  20140929
   Description:
   Others:
   Function List:
   1.Date:2015.03.31
     Author: liping.chen
     Modification:  解压缩，FTP遍历创建新目录，上传
 *******************************************************************************}
 unit UFtpContentThd;
 
 interface
 
 uses
   Classes,Forms,Dialogs,SysUtils,Windows,VCLZip,VCLUnZip,IdFTP,IdFTPList,fClientDataModule,
   IdFTPListParseWindowsNT,IdAllFTPListParsers,DateUtils,SyncObjs;
 
 type
   TLogMsgProc = procedure (AMsg: string; const blnIsErrorMsg: boolean = False; const BoolSaveToFile: Boolean = True);
 
   TFtpContentThd = class(TThread)
   private
     FStart_Date,FEnd_Date,FNextDate :TDateTime;// 获取起始时间\获取结束时间\增加分钟 计算出结束时间
 
     FCount :Integer;
     FContent: wideString;
   protected
     ziper:TVCLZip;
     IdFTP: TIdFTP;
     FLogMsg: TLogMsgProc;
     Filename:string;  //生成压缩文件名
     FMessage: string;  //消息
     ZipUpLoadDir,ZipUpLoadDirTemp:string;  //上传FTP的路径
     FDeptID:string;  //出票点ID
     pub_Critical: TCriticalSection;          //临界区
     //--------------
     procedure DoPostContent(var HasData: boolean);
     //定区间
     function Get_Bak_Date : Boolean;   //获取时间段
     //取，存，压缩
     Function Get_ContentByDate(var HasData: boolean) : Boolean;  // 根据推送的时间段，从票据打印表中取出数据获取，存为txt
     //上传
     Function UpLoad_Content_Zip :Boolean;                        //上传Zip包
     //更新
     Function Update_Content_Bak_Date : Boolean;
   public
     constructor Create(LogMsgProc: TLogMsgProc);
     procedure LogInfo(AMsg: string; const blnIsErrorMsg: boolean = False; const BoolSaveToFile: Boolean = True);
     destructor  Destroy;override;
     function CreatFtpDir(UpLoadDir:string): Boolean;  //遍历当前FTP文件夹， 创建新目录或更改路径
     function  DeleteDirectory(NowPath: string): Boolean; // 循环删除整个目录下的所有文件包括文件夹
     function Zip(ZipMode,packSize:Integer;ZipFile,UnzipDir:string):Boolean;
   protected
     procedure Execute; override;
   end;
 
 var
    FtpContentThd:TFtpContentThd;
 implementation
 uses
   UPubTypeVarCon,UFrmMain,UPubFuncProc;
 
 { TFtpContentThd }
 
 constructor TFtpContentThd.Create(LogMsgProc: TLogMsgProc);
 var
   sFilePath:string;
 begin
   sFilePath:=ExtractFilePath(Application.ExeName);
   if sFilePath[Length(sFilePath)] <> '\' then sFilePath := sFilePath + '\';
   pub_UnZipFileSaveDir:=sFilePath+'PostContentRunLog\ConTxt';
   pub_ZipFileSaveDir:=sFilePath+ 'PostContentRunLog\ConZip';
 
   if not DirectoryExists(pub_UnZipFileSaveDir) then  //未压缩的文件保存路径
     CreateDir(pub_UnZipFileSaveDir);
   if not DirectoryExists(pub_ZipFileSaveDir) then  //压缩包保存路径
     CreateDir(pub_ZipFileSaveDir);
   DeleteDirectory(pub_UnZipFileSaveDir); //每次打开先删除这两个目录下的所有文件
   DeleteDirectory(pub_ZipFileSaveDir);
   //此处要删除 上一次的txt和zip； 若改进为断点续传，可变更逻辑
 
   try
     inherited Create(True);
     FreeOnTerminate := True;
     FLogMsg:=LogMsgProc;
     //FDeptID:='6';
     pub_Critical := TCriticalSection.create;
     ziper:=TVCLZip.Create(nil);
     IdFTP:=TIdFTP.Create;
     LogInfo('创建FTP上传线程成功!',true,true);
 
     Resume;
   except
     on e:exception do
     begin
       FMessage:='创建FTP上传线程出错!'#+e.Message;
       LogInfo(FMessage,true,true);
     end;
   end;
 end;
 
 procedure TFtpContentThd.Execute;
 var
   HasData: boolean;
 begin
   while not Terminated do
   begin
 
     DoPostContent(HasData);
 
     if HasData then
       Sleep()
     else
       Sleep(pub_FtpExecInterval * );  //等待中
   end;
 end;
 
 {Zip用法：Zip(压缩模式，压缩包大小，压缩或解压文件，解压或压缩目录，TVCLZip控件)
  ZipMode为0：压缩；为1：解压缩　PackSize为0则不分包；否则为分包的大小  }
 function TFtpContentThd.Zip(ZipMode, packSize: Integer; ZipFile,
   UnzipDir: string): Boolean;
 begin
   if copy(UnzipDir,length(UnzipDir),)='\'then
       UnzipDir:=copy(UnzipDir,,length(UnzipDir)-);//去除目录后的'\'
   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文档，若需压缩全部可\*.*
       //ziper.
       Application.ProcessMessages;
       ziper.Zip;
     end else
     begin
       ziper.DestDir:=UnzipDir;  //解压缩的目标目录
       ziper.UnZip;              //解压缩
     end;
     Result:=True;
   except
    on ex:exception do
    begin
      Result:=False;
      FMessage := '文件解压缩异常'# + ex.Message;
      LogInfo(FMessage,True,True);
    end;
   end;
 end;
 
 {遍历当前FTP文件夹， 创建新目录或更改路径}
 function TFtpContentThd.CreatFtpDir(UpLoadDir: string): Boolean;
 var
   CreatDirList: TStringList;
   i,j,flag:Integer;
 begin
   CreatDirList:=TStringList.Create;
   CreatDirList.Delimiter :='\';
   CreatDirList.DelimitedText :=UpLoadDir;
   for i :=  to CreatDirList.Count -  do
   begin
     if CreatDirList[i]<>'' then
     begin
       flag:=;
       IdFTP.List;
       //ShowMessage(IntToStr(IdFTP.DirectoryListing.Count));  //默认uses idftplistParse异常；要添加IdFTPListParseWindowsNT,IdAllFTPListParsers单元
       for j :=   to IdFTP.DirectoryListing.Count- 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:=;  //标志已经存在该目录
             Break;
           end;
         end;
       end;
       if flag= 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
           LogInfo('添加目录名:'+CreatDirList[i]+'出错,原因：'+ex.Message,True,True );
         end;
         try
           IdFTP.ChangeDir(CreatDirList[i]);
         except on ex:Exception do
           LogInfo('变更目录名:'+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;
   CreatDirList.Free;
   Result :=True;
 end;
 
 destructor TFtpContentThd.Destroy;
 begin
   //inherited; //继承会产生异常  为什么？？
   ziper.Free;
   IdFTP.Free;
   pub_Critical.Free;
   try
     LogInfo('FTP上传线程终止',False,true);
     FtpContentThd.Terminate;
     WaitForSingleObject(FtpContentThd.Handle, );
     FtpContentThd := nil;
   except on ex:Exception do
     begin
 
     end;
   end;
 end;
 
 function TFtpContentThd.Get_Bak_Date: Boolean;
 var
   sql1 :string;
   count :integer;
   Now_Date :TDateTime;
 begin
   Result := True;
   Now_Date := StrToDateTime(FormatDateTime('YYYY/MM/DD hh:mm:ss',Now()));
   //获取时间段内的票面内容
   Sql1 := 'SELECT * FROM TICKET_CONTENT_BAK_DATE WHERE STATUS = 0';
   try
     try
       with ClientDataModule.orqry1 do
       begin
         SQL.Clear;
         SQL.Text := sql1;
         Open;
         First;
         count := RecordCount;
         if Count =  then
         begin
           //临时增加一条数据，否则程序无法进行
           FMessage := '上传票面内容时，未找到相应上传区间。';
           LogInfo(FMessage,True);
           Result := False;
           Exit;
         end;
         // 获取相关信息
         FStart_Date := FieldByName('START_DATE').AsDateTime;  // 获取起始时间
         FEnd_Date := fieldByName('END_DATE').AsDateTime;      // 获取结束时间
         FNextDate := IncSecond(FEnd_Date,Pub_SecondInterval);
         Close;
       end;
       Now_Date := IncMinute(Now_Date,-Pub_Before_Minitue);  //只取Now()前5分钟的数据；
       If FNextDate > Now_Date then
       begin
         Result := False;
       end;
     except on Ex:Exception do
       begin
         FMessage := '查找相应上传区间时,服务器断开或异常。';
         LogInfo(FMessage,True);
         Result := False;
       end;
     end;
   finally
 
   end;
 end;
 
 function TFtpContentThd.Get_ContentByDate(var HasData: boolean): Boolean;
 var
   sql1,s :string;
   s_TID,s_CheckNo :string;
   s_content,s_content_left,s_content_right :widestring;
   Msg :string;
   i : Integer;
 begin
   Result := True;
   Msg := '查找票面内容，如下区间：';
   Msg := Msg + Formatdatetime('YYYY-MM-DD hh:mm:ss',FStart_Date);
   Msg := Msg + ' -- ';
   Msg := Msg + Formatdatetime('YYYY-MM-DD hh:mm:ss',FEnd_Date);
   LogInfo(Msg);
   // 根据推送的时间段，从票据打印表中取出数据
   Sql1 := ' SELECT A.TID,A.CHECK_NO,B.CONTENT FROM TICKET_PRINT_HISTORY A,TICKET_CONTENT B ' +
          ' WHERE A.TID=B.TID ' +
          ' AND A.PRINT_TIME >= TO_DATE(' + Quotedstr(DateTimeToStr(FStart_Date)) + ',' + Quotedstr('yyyy-mm-dd hh24:mi:ss') + ')' +
          ' AND A.PRINT_TIME < TO_DATE(' + Quotedstr(DateTimeToStr(FEnd_Date)) + ',' + Quotedstr('yyyy-mm-dd hh24:mi:ss') + ')';
   //测试语句
   //sql1 := 'SELECT TID,CHECK_NO FROM TICKET_PRINT_HISTORY WHERE TID >= 39332133 AND TID<=39334764';
 
   try
     try
       with ClientDataModule.orqry1 do
       begin
         try
           sql.Clear;
           SQL.Text := sql1;
           Open;
           First;
           FCount := RecordCount;
           if FCount >  then
           begin
             HasData := True;
             LogInfo('开始解析票面内容。总数为： ' + IntToStr(FCount) + '条。');
           end
           else
           begin
             HasData := False;
             FMessage := '查找区间票面内容为空。';
             LogInfo(FMessage);
             Result := True;
             Exit;
           end;
           while not Eof do
           begin
             Try
               s_TID := FieldByName('TID').asstring;
               LogInfo('解析票面内容。票ID为：' + s_TID,False,True);  //不需要写日志吧
               FContent := Trim(FieldByName('CONTENT').Asstring);
               //FContent := Trim(FieldByName('CHECK_NO').Asstring);   //ss测试语句
               pub_Critical.Enter;
               try
                 WriteLog(pub_UnZipFileSaveDir+'\' +s_TID+ '.Txt',FContent,True); //若存在该文件，覆盖模式
               finally
                 pub_Critical.Leave;
               end;
               Next;
             except on Ex:Exception do
               begin
                 FMessage := '解析单张票面内容时，出现异常。' + Ex.Message;
                 LogInfo(FMessage,True);
                 Result := False;
                 Exit;
               end;
             end;
           end;
           Close;
         Except on Ex:Exception do
           begin
             Close;
             FMessage := '查找区间内票面内容时，服务器断开或异常。' + Ex.Message;
             LogInfo(FMessage,True);
             //获取数据时出现异常
             Result := False;
           end;
         end;
       end;
     Except on Ex:Exception do
       begin
         FMessage := '查找区间内票面内容时，服务器断开或异常。' + Ex.Message;
         LogInfo(FMessage,True);
         //获取数据时出现异常
         Result := False;
       end;
     end;
   finally
   end;
 end;
 
 procedure TFtpContentThd.DoPostContent(var HasData: boolean);
 begin
   HasData := False;
   try
     //1、从数据库取得指定区间的数据，保存为多个txt，
     //2、当前文件夹的*.txt全部保存为zip
     //3、ftp上传到服务器
 
     LogInfo('开始取区间');
     if not Get_Bak_Date then Exit;
     LogInfo('开始取区间内票面内容');
     //ss -------测试
     //FStart_Date:=Now();
     //FEnd_Date:=Now();
     if not Get_ContentByDate(HasData) then Exit;
 
     DateTimeToString(Filename,'YYYYMMDD-HHMMSS',FStart_Date);  //压缩包名称，以区间开始时间命名
     Filename:=Filename+'.zip';
 
     LogInfo('执行压缩');
     if not Zip(,,pub_ZipFileSaveDir+'\'+Filename,pub_UnZipFileSaveDir) then  //将abc.zip解压到路径，若不存在会自动创建目录的。
     begin                                                                      //压缩时，若路径不存在，是否会创建；
      exit;
     end;
 
     LogInfo('提交票面内容压缩包到文件服务器');
     DateTimeToString(ZipUpLoadDir,'YYYY\MM\DD\HH',Now); //压缩包上传路径
     if not UpLoad_Content_Zip then Exit;
     LogInfo('更新提交状态');
     if not Update_Content_Bak_Date then Exit;
     LogInfo('执行下一批数据');
   finally
 
   end;
 end;
 
 function TFtpContentThd.UpLoad_Content_Zip: Boolean;
 begin
   //发送
   Result:=False;
   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服务器出错!'#+e.Message;
           LogInfo(FMessage,true,true);
           Exit;
         end;
       end;
     end;
     if Connected then
     begin
       if ZipUpLoadDirTemp<>ZipUpLoadDir  then  //上传保存的路径改变，则创建新目录或更改路径。
       begin
         ChangeDir(pub_ZipUpLoadRtDir);  //先回到设定的根目录
         CreatFtpDir(ZipUpLoadDir);      //遍历当前FTP文件夹， 创建新目录或更改路径
       end;
       try
         Put(pub_ZipFileSaveDir+'\'+Filename,Filename);
 
         deletefile(PChar(pub_ZipFileSaveDir+'\'+Filename)); //删除已上传的文件
         DeleteDirectory(pub_UnZipFileSaveDir);    //删除已经上传的文件夹的所有txt
       except
         on e:exception do
         begin
           FMessage:='文件上传FTP服务器出错!'#+e.Message;
           LogInfo(FMessage,true,true);
           Exit;
         end;
       end;
     end;
   end;
   ZipUpLoadDirTemp:=ZipUpLoadDir;
   Result:=True;
 end;
 
 function TFtpContentThd.Update_Content_Bak_Date: Boolean;
 var
   sql1,sql2 : string;
 begin
   Result := True;
   try
     // 如果上面对数据进行处理出现异常时，则退出本次上传
     // 全部数据上传成功，则进行状态重置
     Sql1 := 'BEGIN  UPDATE TICKET_CONTENT_BAK_DATE SET STATUS=1,POST_DATE=SYSDATE, ' +
            ' POST_COUNT=' + Quotedstr(IntTostr(FCount)) +
            ' WHERE STATUS = 0;';
 
     // 插入下一条上传时间段
     sql2 := ' INSERT INTO TICKET_CONTENT_BAK_DATE (ID,START_DATE,END_DATE,POST_COUNT,POST_DATE,STATUS) ' +
            ' VALUES(SEQ_CONTENT_BAK_DATE.Nextval,TO_DATE('+ Quotedstr(Formatdatetime('YYYY-MM-DD hh:mm:ss',FEnd_Date)) +
            ',' + QuotedStr('yyyy-mm-dd hh24:mi:ss') + '),TO_DATE(' + Quotedstr(Formatdatetime('YYYY-MM-DD hh:mm:ss',FNextDate)) +
            ',' + QuotedStr('yyyy-mm-dd hh24:mi:ss') + '),0,SYSDATE,0);' +
            ' COMMIT; END;' ;
     ClientDataModule.orqry1.SQL.Clear;
     ClientDataModule.orqry1.SQL.Text := sql1 + sql2;
     ClientDataModule.orqry1.Execute;
     ClientDataModule.orqry1.Close;
     //
     //LogInfo('建立下一次上传区间');
   except on ex:exception do
     begin
       FMessage := '更新上传状态时，服务器断开或异常。' + Ex.Message;
       LogInfo(FMessage,True);
       Result := False;
     end;
   end;
 end;
 
 {循环删除整个目录下的所有文件包括文件夹}
 function TFtpContentThd.DeleteDirectory(NowPath: string): Boolean;
 var
   search: TSearchRec;
   ret: integer;
   key: string;
 begin
   Result:=False;
   if NowPath[Length(NowPath)] <> '\' then
     NowPath := NowPath + '\';
   key := NowPath + '*.*';
   ret := findFirst(key, faanyfile, search);
   while ret =  do
   begin
     if ((search.Attr and fadirectory) = fadirectory) then
     begin
       if (search.Name <> '.') and (search.name <> '..') then
       begin
         DeleteDirectory(NowPath + search.name);
         removedir(NowPath + search.name); //如果需要删除文件夹则添加
       end;
     end
     else
     begin
       if ((search.Attr and fadirectory) <> fadirectory) then
       begin
         deletefile(PAnsiChar(NowPath + search.name));
 
       end;
     end;
     ret := FindNext(search);
   end;
   SysUtils.FindClose(search);
   //FindClose(search.FindHandle);
   //FindClose(search); //发现在线程里面不能用这，只能用上面的句柄
   //removedir(NowPath); //如果需要删除最外层文件夹则添加
   result := True;
 end;
 procedure TFtpContentThd.LogInfo(AMsg: string; const blnIsErrorMsg,
   BoolSaveToFile: Boolean);
 begin
   pub_Critical.Enter;
   try
     FLogMsg(AMsg,blnIsErrorMsg,BoolSaveToFile);
   finally
     pub_Critical.Leave;
   end;
 end;
 
 initialization
   //
 finalization
   //
 end.

代码

 procedure TFrmFTP_ZIP.btnBreUpLoadClick(Sender: TObject);
 var
   tStream: TFileStream;
   Size1:Integer;
 begin
   if IdFTP1.Connected then
   begin
     if not UploadOpenDialog1.Execute then
       Exit;
     tStream:=TFileStream.Create(UploadOpenDialog1.FileName,fmOpenRead );
     try
       Size1 :=IdFTP1.Size(ExtractFileName(UploadOpenDialog1.FileName));
       if Size1 > then   //这样判断文件是否存在 是错误的。
       begin
         case MessageDlg('文件已经存在，是否续传？', mtConfirmation, mbYesNoCancel, ) of
           mrYes:
             begin
               tStream.Position:=Size1;
               //tStream.Seek(IdFTP1.Size('Delphi大量pdf资料非扫描档1.zip'),0) ; //也可以。
               IdFTP1.Put(tStream,ExtractFileName(UploadOpenDialog1.FileName),true); //续传
             end;
           mrNo:
             begin
               IdFTP1.Put(tStream,ExtractFileName(UploadOpenDialog1.FileName),False); //重新传
             end;
           mrCancel: Exit; //取消
         end;
       end
       else
         IdFTP1.Put(tStream,ExtractFileName(UploadOpenDialog1.FileName),False);
 
      { tStream.Position:=IdFTP1.Size('Delphi大量pdf资料非扫描档1.zip'); //当前路径的指定文件
       //tStream.Seek(IdFTP1.Size('Delphi大量pdf资料非扫描档1.zip'),0) ; //也可以。
       IdFTP1.Put(tStream,'Delphi大量pdf资料非扫描档1.zip',true); }
 
     finally
       tStream.Free;
     end;
   end
   else
     ShowMessage('Ftp未连接');
 end;
 
 procedure TFrmFTP_ZIP.btnBreDownLoadClick(Sender: TObject);
 begin
   if IdFTP1.Connected then
   begin
     if FileExists('Delphi大量pdf资料非扫描档1.zip') then
     begin
       case MessageDlg('文件已经存在，是否续传？', mtConfirmation, mbYesNoCancel, ) of
         mrYes: FtpDownLoad( 'Delphi大量pdf资料非扫描档1.zip', True); //续传
         mrNo: FtpDownLoad( 'Delphi大量pdf资料非扫描档1.zip', False); //覆盖
         mrCancel: Exit; //取消
       end;
     end
     else
       FtpDownLoad( 'Delphi大量pdf资料非扫描档1.zip', False); //建立新文件下载
   end
   else
     ShowMessage('Ftp未连接');
 end;

断点上传和断点下载代码