如何在一个指定的文件夹下找到并删除所有文件？

Question

procedure xcopy(source: string;dest:string);
var
  sr: TSearchRec;
const
  fileattrs=63;
begin
  try
     mkdir(dest);
  except
  end;
  source:=source+'\*.*';
  if FindFirst(source, fileattrs, sr) = 0 then
  begin
      if (sr.Name <>'.') and (sr.name<>'..') then
      begin
        if ((sr.attr and fadirectory)=fadirectory)  then
                xcopy(extractfilepath(source)+sr.name,dest+'\'+sr.name)
        else
              begin
                  copyfile(pchar(extractfilepath(source)+sr.name),pchar(dest+'\'+sr.name),false);
                  if strToFloat(form1.Edit3.Text)<>0 then
                  begin
                  dodo:=0;
                  Form1.Timer1.Enabled :=true;
                  while dodo=0 do
                  begin
                        Application.ProcessMessages;
                  end;
                  Form1.Timer1.Enabled :=false;
                  end;
              end;
      end;
      while FindNext(sr) = 0 do
      begin
        if  (sr.Name <>'.') and (sr.name<>'..') then
        begin
        if ((sr.attr and fadirectory)=fadirectory)  then
                xcopy(extractfilepath(source)+sr.name,dest+'\'+sr.name)
        else
             begin
                 copyfile(pchar(extractfilepath(source)+sr.name),pchar(dest+'\'+sr.name),false);
                 if strTofloat(form1.Edit3.Text)<>0 then
                 begin
                 dodo:=0;
                 Form1.Timer1.Enabled :=true;
                 while dodo=0 do
                 begin
                        Application.ProcessMessages;
                 end;
                 Form1.Timer1.Enabled :=false;
                 end;
             end;
        Application.ProcessMessages ;
        end;
      end;
      FindClose(sr);  end;end;

Answer 1

目录、文件方面
删除一子目录及其下面的文件--------------------------------------------------------------------------------
 
删除一子目录及其下面的文件 
    The following example demonstrates deleting all the files in a directory and then the directory itself. Additional processing would be required to delete read only files and files that are in use. procedure TForm1.Button1Click(Sender: TObject);
var
    DirInfo: TSearchRec;
    r : Integer;
begin
    r := FindFirst('C:\Download\Test\*.*', FaAnyfile, DirInfo);
    while r = 0 do
        begin
            if ((DirInfo.Attr and FaDirectory <> FaDirectory) and
               (DirInfo.Attr and FaVolumeId <> FaVolumeID)) then
                  if DeleteFile(pChar('C:\Download\test\' + DirInfo.Name)) = false then
                     ShowMessage('Unable to delete : C:\Download\test\' + DirInfo.Name);
            r := FindNext(DirInfo);
        end;
    SysUtils.FindClose(DirInfo);
    if RemoveDirectory('C:\Download\Test') = false then
        ShowMessage('Unable to delete direcotry : C:\Download\test');
end;
 -------------------------------------------------------------------------------- 

Answer 2

关于文件、目录操作
Chdir('c:\abcdir');转到目录
Mkdir('dirname');建立目录
Rmdir('dirname');删除目录
GetCurrentDir;//取当前目录名，无'\'
Getdir(0,s);//取工作目录名s:='c:\abcdir';
Deletfile('abc.txt');//删除文件
Renamefile('old.txt','new.txt');//文件更名
ExtractFilename(filelistbox1.filename);//取文件名
ExtractFileExt(filelistbox1.filename);//取文件后缀

Answer 3

Procedure TForm1.MyCallback(filename:string);
begin
  inc(count);
  label1.caption:=inttostr(count);
  label1.Update;
  listbox4.items.add(filename);
end;Procedure TForm1.RecurseDirectory(Dir : String;
                           IncludeSubs : boolean;
                           callback : TFileCallbackProcedure);
var
  SearchRec :TSearchRec;
  Result : LongInt;
begin
    Result := FindFirst(Dir+'\*.*', faAnyFile , SearchRec);
    while Result = 0 do
    begin
      { This makes sure its not the . or .. directorys}
      if not(SearchRec.name[1]='.') then
      begin
       if (SearchRec.attr and faDirectory) <> 0 then
        begin
          {its a dir so do a recursive call if subdirectorys wanted}
          if IncludeSubs then
            RecurseDirectory(Dir +'\' + SearchRec.name,IncludeSubs, callback);
        end
        else
          { Call are callback function}
          callback(dir+'\'+SearchRec.name);
      end; //if . ..
      Result := FindNext(SearchRec);
    end;
end;用findfirst,findnext,findclose+递归也可以，不过效率比以上的代码差多了。

Answer 4

用findfirst、findnext查找，
然后用deletefile删除文件。

Answer 5

type
    TFileCallbackProcedure = procedure(filename:string) of object;Procedure TForm1.MyCallback(filename:string);
begin
  inc(count);
  label1.caption:=inttostr(count);
  label1.Update;
  listbox4.items.add(filename);
end;Procedure TForm1.RecurseDirectory(Dir : String;
                           IncludeSubs : boolean;
                           callback : TFileCallbackProcedure);
var
  SearchRec :TSearchRec;
  Result : LongInt;
begin
    Result := FindFirst(Dir+'\*.*', faAnyFile , SearchRec);
    while Result = 0 do
    begin
      { This makes sure its not the . or .. directorys}
      if not(SearchRec.name[1]='.') then
      begin
       if (SearchRec.attr and faDirectory) <> 0 then
        begin
          {its a dir so do a recursive call if subdirectorys wanted}
          if IncludeSubs then
            RecurseDirectory(Dir +'\' + SearchRec.name,IncludeSubs, callback);
        end
        else
          { Call are callback function}
          callback(dir+'\'+SearchRec.name);
      end; //if . ..
      Result := FindNext(SearchRec);
    end;
end;procedure TForm1.Button4Click(Sender: TObject);
begin
    RecurseDirectory('c:',true,MyCallback);
end;以上做的是找到文件，删除还不是小菜一碟，效率比用递归可高多了.

Answer 6

uses
  shellapi,filectrl;implementation
procedure TForm1.Button1Click(Sender: TObject);
var
  opstruc:tshfileopstruct;
  frombuf:array[0..128]of char;
begin
  fillchar(frombuf,sizeof(frombuf),0);
  strpcopy(frombuf,pchar(edit1.Text));//edit1.text为你想要删除文件的目录
  //开始填充opstruc记录
  with opstruc do
  begin
    wnd:=handle;
    wfunc:=fo_delete;
    pfrom:=@frombuf;
    pto:=nil;
    fflags:=fof_noconfirmation;
    lpszprogresstitle:='正在删除';
  end;
  if shfileoperation(opstruc)=0then
    messagebox(handle,'删除完毕。','删除信息',mb_ok+mb_iconinformation);
  mkdir(edit1.Text);
end;

Answer 7

unit DeleTree; interface 
uses Classes, FileCtrl, SysUtils; procedure RemoveTree(path: string); 
procedure RemoveDirectory(path: string); 
procedure GetFileList(FileSpec: string;
                       NamesOnly: Boolean;
                       var FileList: TStringList); 
procedure GetSubDirList(DirRoot: string;
                       NamesOnly: Boolean;
                       var SubDirList: TStringList); 
function BackSlash(FileSpec: string): string; 
function NoBackSlash(FileSpec: string): string; implementation {--------------------------------------------------------} 
{这个过程删除整个目录树} 
procedure RemoveTree(path: string); 
var
  SubDirList: TStringList;
  FileList: TStringList;
  i: integer; 
begin
  SubDirList := TStringList.Create;
  GetSubDirList(path,False,SubDirList);
  {如果这个树含有子目录，递归调用删除每一个子目录树}
  if SubDirList.Count>0 then
  begin
    for i := 0 to SubDirList.Count-1 do
    begin
      RemoveTree(SubDirList[i]);
    end;
  end;
  SubDirList.free;
  {到这一步所有的子目录树都已被删除，或者根本不存在。因而你们仅需要删除所有的文件}
  FileList := TStringList.Create;
  GetFileList(BackSlash(path)+'*.*',False,FileList);
  for i := 0 to FileList.Count-1 do
  begin
    DeleteFile(PChar(FileList[i]));
  end;
  FileList.Free;
  RemoveDirectory(path); 
end; 
{--------------------------------------------------------} 
{这个过程将删除目录(如果它存在)} 
procedure RemoveDirectory(path: string); 
var
  Dir: string; 
begin
  {删除反斜线(如果它存在)}
  Dir := NoBackSlash(path);
  if DirectoryExists(Dir) then RmDir(Dir); 
end; {--------------------------------------------------------} 
{这个过程把所有匹配文件规格的文件名加入一个StringList。如果NamesOnly是true，那么不包含文件路径} 
procedure GetFileList(FileSpec: string;
                      NamesOnly: Boolean;
                      var FileList: TStringList); 
var
  SR: TSearchRec;
  DosError: integer; 
begin
  FileList.Clear;
  DosError := FindFirst(FileSpec, faAnyFile-faDirectory, SR);
  while DosError=0 do
  begin
    if NamesOnly
      then FileList.Add(SR.Name)
      else FileList.Add(ExtractFilePath(FileSpec)+SR.Name);
    DosError := FindNext(SR);
  end; 
end; {--------------------------------------------------------} 
{这个过程将指定的目录的全部下级目录名加入StringList。如果NamesOnly是true，那么仅仅包括最下级目录名} 
procedure GetSubDirList(DirRoot: string;
                        NamesOnly: Boolean;
                        var SubDirList: TStringList); 
var
  SR: TSearchRec;
  DosError: integer;
  Root: string; 
begin
  SubDirList.Clear;
  {在最后加入一个反斜杠(如果不存在)}
  Root := BackSlash(DirRoot);
  {使用FindFirst/FindNext返回下级目录}
  DosError := FindFirst(Root+'*.*', faDirectory, SR);
  while DosError=0 do
  begin
    {don't include the directories . and ..}
    if pos('.',SR.Name)<>1 then
    begin
      if SR.Attr=faDirectory then
      begin
        if NamesOnly
          then SubDirList.Add(SR.Name)
          else SubDirList.Add(Root+SR.Name);
      end;
    end;
    DosError := FindNext(SR);
  end; 
end; {--------------------------------------------------------} 
{添加一个反斜杠(如果它不存在)} 
function BackSlash(FileSpec: string): string; 
begin
  if (FileSpec[length(FileSpec)]<>'\')
     then Result := FileSpec+'\'
     else Result := FileSpec; 
end; {删除一个反斜杠(如果它存在)} 
function NoBackSlash(FileSpec: string): string; 
begin
  if (FileSpec[length(FileSpec)]='\')
     then Result := Copy(FileSpec,1,length(FileSpec)-1)
     else Result := FileSpec; 
end; end.