随笔 - 6  文章 - 129  trackbacks - 0
<2024年12月>
24252627282930
1234567
891011121314
15161718192021
22232425262728
2930311234

常用链接

留言簿(14)

随笔档案(6)

文章分类(467)

文章档案(423)

相册

收藏夹(18)

JAVA

搜索

  •  

积分与排名

  • 积分 - 822342
  • 排名 - 49

最新评论

阅读排行榜

评论排行榜

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 阅读(970) 评论(0)  编辑  收藏 所属分类: delphi

只有注册用户登录后才能发表评论。


网站导航: