Delphi中關于文件、目錄操作的函數
來源：大富翁
關于文件、目錄操作
Chdir('c:\abcdir'); // 轉到目錄
Mkdir('dirname'); //建立目錄
DirectoryExists('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;
posted on 2010-02-25 15:31
Ke 閱讀(996)
評論(0) 編輯 收藏 所屬分類:
delphi