5. Use the control Tvclzip and tidftp to compress the file and upload it to the FTP thread unit pas

{******************************************************************************* Copyright (C), 2014-2020, Aicaipiao File name:UFtpContentThd.pas author:lipingchen version:date:20140929 Description:Others:Function L IST: Extract Files FTP traversal Create new directory timing *******************************************************************************}unit UFTP Contentthd;interfaceuses Classes,forms,dialogs,sysutils,windows,vclzip,vclunzip,idftp,idftplist,    Idftplistparsewindowsnt,idallftplistparsers;type TFTPCONTENTTHD = Class (TThread) private protected ziper:tvclzip;    Idftp:tidftp;  filename:string;  Generate compressed file name fmessage:string;  Message zipuploaddir,zipuploaddirtemp:string;  Upload the FTP path fdeptid:string;    Ticketing Point ID public constructor Create;    destructor Destroy;override;  function Creatftpdir (uploaddir:string): Boolean; Traverse the current FTP folder, create a new directory or change the path//usage: ZIP (compression mode, compress package size, compress or unzip the file, unzip or compress the directory, Tvclzip Control)//zipmode to 0: compress; 1: Unzip packsize to 0 without subcontracting; Size function Zip for subcontracting (zipmode,packsIze:integer;  zipfile,unzipdir:string): Boolean; protected procedure Execute;  Override End;var ftpcontentthd:tftpcontentthd;implementationuses Upubtypevarcon; {TFTPCONTENTTHD}constructor Tftpcontentthd.create;begin if not directoryexists (Pub_zipfilesavedir) then//Compress package save path C  Reatedir (Pub_zipfilesavedir);    Try inherited Create (True);    Freeonterminate: = True;    Resume;    fdeptid:= ' 6 ';    Ziper:=tvclzip.create (nil);    Idftp:=tidftp.create;  Logmsg (' Create FTP upload thread succeeded! ', true,true); Except on E:exception do begin fmessage:= ' Create FTP upload thread error! '      #13 +e.message;    Logmsg (fmessage,true,true);  End End;end;procedure Tftpcontentthd.execute;begin While not Terminated does 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//unzip the Abc.zip to the path, and automatically create the directory if it does not exist.  Begin//Execution Failure Sleep (pub_ftpexecinterval * 1000);   Wait for a moment Continue;    exit; end;        Send with IDFTP does 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:= ' connection to FTP server Error! '            #13 +e.message;            Logmsg (fmessage,true,true);          break;        End      End      End        If Connected then BEGIN if Zipuploaddirtemp<>zipuploaddir and then//upload saved path changes, create a new directory or change the path.  Begin Changedir (PUB_ZIPUPLOADRTDIR);        Go back to the set root directory Creatftpdir (zipuploaddir);        End          Try Put (pub_zipfilesavedir+ ' \ ' +filename,filename);  Sleep (Pub_ftpexecinterval * 1000); Wait in DeleteFile (PChar (pub_zipfilesavedir+ ' +filename)); Delete uploaded files except on e:exception Do begin fmessage:= ' File upload FTP server Error! '            #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,le Ngth (Unzipdir)-1);//Remove directory after the ' \ ' try Ziper. doall:=false;//This setting will extract invalid Ziper for the sub-package file. overwritemode:=always;//always overwrites the mode if Packsize<>0then//0 is compressed into a file, otherwise pressed into a multi-file begin Ziper. multizipinfo.multimode:=mmblocks;//Set the subcontracting mode Ziper. multizipinfo.savezipinfoonfirstdisk:=true;//packaging information is saved in the first file ziper. multizipinfo.firstblocksize:=packsize;//Sub-Package header file size ziper.    multizipinfo.blocksize:=packsize;//other sub-package file size end; Ziper.    Fileslist.clear; Ziper. zipname:=zipfile;//gets the compressed file name if Zipmode=0then//compression begin ziper.  Fileslist.add (unzipdir+ ' \*.txt '); The Add compressed file list is set to |*.txt document, if you need to compress all \*.* APplication.      ProcessMessages; Ziper.    Zip; End ELSE begin Ziper. destdir:=unzipdir;//the extracted target directory ziper.           UnZip;    Decompression end;  Result:=true;     Except on ex:exception do begin result:=false; Fmessage: = ' file uncompressed exception ' #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)); Default uses Idftplistparse exception; To add Idftplistparsewindowsnt,idallftplistparsers cell for J: = 0 to IdFTP.DirectoryListing.Coun                 T-1 do//indy10 to add idftplistparsewindowsnt,idallftplistparsers cell begin                                  Description: http://blog.sunshow.net/2007/07/tidftp-directorylisting-usage/if Idftp.dire CTORYLISTING.ITEMS[J]. ItemType = Ditdirectory then//To add cells idftplist begin if IDFTP.DIRECTORYLISTING.ITEMS[J].  FileName = Creatdirlist[i] THEN begin flag:=1;          Flag already exists for this directory break;        End      End      End  If Flag=0 then Idftp.makedir (Creatdirlist[i]);  Newly created folder Idftp.changedir (Creatdirlist[i]);    Change the directory end; The following dirlist content has a space, IndexOf (Creatdirlist[i]) can not be recognized, nor rigorous * * * {if creatdirlist[i]<> ' then begin Idftp.list (Di      RList, ", True);        if (Dirlist.indexof (Creatdirlist[i]) =-1) THEN begin try Idftp.makedir (Creatdirlist[i]); Except on Ex:exception do logmsg (' Add directory Name: ' +creatdirlist[i]+ ' error, Reason: ' +ex.        Message,true,true);        End        Try Idftp.changedir (Creatdirlist[i]); Except on Ex:exception do logmsg (' Change directory name: ' +CREATDIrlist[i]+ ' Error, Reason: ' +ex.        Message,true,true);      End    End End    }//*** The following ignore exceptions, lazy writing, * * * {try Idftp.changedir (creatdirlist[i]);      Except Idftp.makedir (Creatdirlist[i]);    Idftp.changedir (Creatdirlist[i]);    End;}    The following ignore exceptions, lazy writing, * * * {try Idftp.makedir (creatdirlist[i]);    Finally Idftp.changedir (Creatdirlist[i]);   End  } end; Result: =true;end;destructor tftpcontentthd.destroy;begin//inherited;  Inheritance can cause an exception why?? Ziper.  Free;  Idftp.free;    Try Ftpcontentthd.terminate;    WaitForSingleObject (Ftpcontentthd.handle, 500);  FTPCONTENTTHD: = nil;  Except on ex:exception do begin end;  End Logmsg (' FTP upload thread termination ', false,true); End;initialization//finalization//end.

　　

5. Use the control Tvclzip and tidftp to compress the file and upload it to the FTP thread unit pas