Delphi中关于文件、目录操作的函数

Delphi中关于文件、目录操作的函数

 

Delphi中关于文件、目录操作的函数
  来源：大富翁
关于文件、目录操作
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);   //取文件后缀
目录处理函数三则:DelTree,XCopy,Move
private
    { Private declarations }
    procedure _XCopy(ASourceDir:String; ADestDir:String);
    procedure _Move(ASourceDir:String; ADestDir:String);
    procedure _DelTree(ASourceDir:String);
//----------------------------------------------------------
procedure TForm1._XCopy(ASourceDir:String; ADestDir:String);
var
FileRec:TSearchrec;
Sour:String;
Dest:String;
begin
  Sour:=ASourceDir;
  Dest:=ADestDir;
  if Sour[Length(Sour)]<>'\' then Sour := Sour + '\';
  if Dest[Length(Dest)]<>'\' then Dest := Dest + '\';
  if not DirectoryExists(ASourceDir) then
     begin
       ShowMessage('来源目录不存在!!');
       exit;
     end;
  if not DirectoryExists(ADestDir) then
     begin
       ForceDirectories(ADestDir);
     end;
  if FindFirst(Sour+'*.*',faAnyfile,FileRec) = 0 then
    repeat
      if ((FileRec.Attr and faDirectory) <> 0) then
         begin
           if (FileRec.Name<>'.') and (FileRec.Name<>'..') then
              begin
                _XCopy(Sour+FileRec.Name,Dest+FileRec.Name);
              end;
         end
      else
         begin
           CopyFile(PChar(Sour+FileRec.Name),PChar(Dest+FileRec.Name),false);
         end;
    until FindNext(FileRec)<>0;
  FindClose(FileRec);
end;
//------------------------------------------------------------------
procedure TForm1._Move(ASourceDir:String; ADestDir:String);
var
FileRec:TSearchrec;
Sour:String;
Dest:String;
begin
  Sour:=ASourceDir;
  Dest:=ADestDir;
  if Sour[Length(Sour)]<>'\' then Sour := Sour + '\';
  if Dest[Length(Dest)]<>'\' then Dest := Dest + '\';
  if not DirectoryExists(ASourceDir) then
     begin
       ShowMessage('来源目录不存在!!');
       exit;
     end;
  if not DirectoryExists(ADestDir) then
     begin
       ForceDirectories(ADestDir);
     end;
  if FindFirst(Sour+'*.*',faAnyfile,FileRec) = 0 then
    repeat
      if ((FileRec.Attr and faDirectory) <> 0) then
         begin
           if (FileRec.Name<>'.') and (FileRec.Name<>'..') then
              begin
                _XCopy(Sour+FileRec.Name,Dest+FileRec.Name);
                _DelTree(Sour+FileRec.Name);
                FileSetAttr(Sour+FileRec.Name,faArchive);
                RemoveDir(Sour+FileRec.Name);
              end;
         end
      else
         begin
           CopyFile(PChar(Sour+FileRec.Name),PChar(Dest+FileRec.Name),false);
           FileSetAttr(Sour+FileRec.Name,faArchive);
           deletefile(Sour+FileRec.Name);
         end;
    until FindNext(FileRec)<>0;
  FindClose(FileRec);
  FileSetAttr(Sour,faArchive);
  RemoveDir(Sour);
end;
//-----------------------------------------------------------
procedure TForm1._DelTree(ASourceDir:String);
var
FileRec:TSearchrec;
Sour:String;
begin
  Sour:=ASourceDir;
  if Sour[Length(Sour)]<>'\' then Sour := Sour + '\';
  if not DirectoryExists(ASourceDir) then
     begin
       ShowMessage('来源目录不存在!!');
       exit;
     end;
  if FindFirst(Sour+'*.*',faAnyfile,FileRec) = 0 then
    repeat
      //if (FileRec.Attr = faDirectory) then
      if ((FileRec.Attr and faDirectory) <> 0) then
         begin
           if (FileRec.Name<>'.') and (FileRec.Name<>'..') then
              begin
                _DelTree(Sour+FileRec.Name);
                FileSetAttr(Sour+FileRec.Name,faArchive);
                RemoveDir(Sour+FileRec.Name);
              end;
         end
      else
         begin
           FileSetAttr(Sour+FileRec.Name,faArchive);
           deletefile(Sour+FileRec.Name);
         end;
    until FindNext(FileRec)<>0;
  FindClose(FileRec);
  FileSetAttr(Sour,faArchive);
  RemoveDir(Sour);
end; 
利用递归实现删除某一目录下所有文件
var Form1: TForm1;
rec_stack:array [1..30] of TSearchRec;
rec_pointer:integer;
Del_Flag:Boolean;
---------------------------------------------------------------
procedure TForm1.DeleteTree(s:string);
VAR searchRec:TSearchRec;
begin
if FindFirst(s+'\*.*', faAnyFile, SearchRec)=0 then
repeat
if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then
begin
if (SearchRec.Attr and faDirectory>0) then
begin
rec_stack[rec_pointer]:=SearchRec;
rec_pointer:=rec_pointer-1;
DeleteTree(s+'\'+SearchRec.Name);
rec_pointer:=rec_pointer+1;
SearchRec:=rec_stack[rec_pointer];
end
else
begin
try
FileSetAttr(s+'\'+SearchRec.Name,faArchive);
DeleteFile(s+'\'+SearchRec.Name);
except
Application.MessageBox(PChar('Delete file:'+s+'\'+SearchRec.Name+' Error!'),'Info',MB_OK);
Del_Flag:=False;
end;
end;
end;
until (FindNext(SearchRec)<>0);
FindClose(SearchRec);
if rec_pointer<30 then
begin
try
FileSetAttr(s,faArchive);
RemoveDir(s);
except
Application.MessageBox(PChar('Delete Directory:'+s+' Error!'),'Info',MB_OK);
Del_Flag:=False;
end;
end;
end;
---------------------------------------------------------
Del_Flag:=True;
rec_pointer:=30;
DeleteTree('c:\temp');
if Del_Flag then Application.MessageBox(PChar('目录c:\temp的内容已成功清除!'),'信息',MB_OK); 
轻轻松松查找文件
  在平常的编程当中，经常会碰到查找某一个目录下某一类文件或者所有文件的问题，为了适应不同的需要，我们经常不得不编写大量的类似的代码，有没有可能写一个通用的查找文件的程序，找到一个文件后就进行处理的呢？这样我们只要编写处理文件的部分就可以了，不需要编写查找文件的部分！答案是肯定的。下面的这个程序就能实现这个功能！
//说明：
//TFindCallBack为回调函数，FindFile函数找到一个匹配的文件之后就会调用这个函数。
//TFindCallBack的第一个参数找到的文件名，你在回调函数中可以根据文件名进行操作。
//TFindCallBack的第二个参数为找到的文件的记录信息，是一个TSearchRec结构。
//TFindCallBack的第三、四个参数分别为决定是否终止文件的查找，临时决定是否查找某个子目录！
//FindFile的参数：
//第一个决定是否退出查找，应该初始化为false；
//第二个为要查找路径；
//第三个为文件名，可以包含Windows所支持的任何通配符的格式；默认所有的文件
//第四个为回调函数，默认为空
//第五个决定是否查找子目录，默认为查找子目录
//第六个决定是否在查找文件的时候处理其他的消息，默认为处理其他的消息
//若有意见和建议请E_Mail：Kingron@163.net
type
  TFindCallBack=procedure (const filename:string;const info:TSearchRec;var bQuit,bSub:boolean);
procedure FindFile(var quit:boolean;const path: String;const filename:string='*.*';
                   proc:TFindCallBack=nil;bSub:boolean=true;const bMsg:boolean=true);
var
  fpath: String;
  info: TsearchRec;
procedure ProcessAFile;
begin
  if (info.Name<>'.') and (info.Name<>'..') and ((info.Attr and faDirectory)<>faDirectory) then
  begin
  if assigned(proc) then
    proc(fpath+info.FindData.cFileName,info,quit,bsub);
  end;
end;
procedure ProcessADirectory;
begin
  if (info.Name<>'.') and (info.Name<>'..') and ((info.attr and fadirectory)=fadirectory) then
    findfile(quit,fpath+info.Name,filename,proc,bsub,bmsg);
end;
begin
if path[length(path)]<>'\' then
  fpath:=path+'\'
else
  fpath:=path;
try
  if 0=findfirst(fpath+filename,faanyfile and (not fadirectory),info) then
  begin
    ProcessAFile;
    while 0=findnext(info) do
      begin
        ProcessAFile;
        if bmsg then application.ProcessMessages;
        if quit then
          begin
            findclose(info);
            exit;
          end;
      end;
  end;
finally
  findclose(info);
end;
try
  if bsub and (0=findfirst(fpath+'*',faanyfile,info)) then
    begin
      ProcessADirectory;
      while findnext(info)=0 do
        ProcessADirectory;
    end;
finally
  findclose(info);
end;
end;
例子：
procedure aaa(const filename:string;const info:tsearchrec;var quit,bsub:boolean);
begin
  form1.listbox1.Items.Add(filename);
  quit:=form1.qqq;
  bsub:=form1.checkbox1.Checked;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
listbox1.Clear;
qqq:=false;
button1.Enabled:=false;
findfile(qqq,edit1.text,edit2.text,aaa,checkbox1.checked,checkbox2.checked);
showmessage(inttostr(listbox1.items.count));
button1.Enabled:=true;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
qqq:=true;
end; 

转载于:https://www.cnblogs.com/zsdentist/archive/2011/11/10/2244772.html