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.