---- 1、拷贝目录 ---- 为了能拷贝目录下带有子目录的情况,先定义一个辅助的拷贝函数,它是递归执行的,直到把目录下的所有文件和子目录都拷贝完。 ---- 1.1拷贝目录的递归辅助函数:DoCopyDir function DoCopyDir(sDirName:String; sToDirName:String):Boolean; var hFindFile:Cardinal; t,tfile:String; sCurDir:String[255]; FindFileData:WIN32_FIND_DATA; begin //先保存当前目录 sCurDir:=GetCurrentDir; ChDir(sDirName); hFindFile:=FindFirstFile('*.*',FindFileData); if hFindFile< >INVALID_HANDLE_VALUE then begin if not DirectoryExists(sToDirName) then ForceDirectories(sToDirName); repeat tfile:=FindFileData.cFileName; if (tfile='.') or (tfile='..') then Continue; if FindFileData.dwFileAttributes= FILE_ATTRIBUTE_DIRECTORY then begin t:=sToDirName+'\'+tfile; if not DirectoryExists(t) then ForceDirectories(t); if sDirName[Length(sDirName)]< >'\' then DoCopyDir(sDirName+'\'+tfile,t) else DoCopyDir(sDirName+tfile,sToDirName+tfile); end else begin t:=sToDirName+'\'+tFile; CopyFile(PChar(tfile),PChar(t),True); end; until FindNextFile(hFindFile,FindFileData)=false; FindClose(hFindFile); end else begin ChDir(sCurDir); result:=false; exit; end; //回到原来的目录下 ChDir(sCurDir); result:=true; end;---- 1.2拷贝目录的函数:CopyDir function CopyDir(sDirName:String; sToDirName:string):Boolean; begin if Length(sDirName)< =0 then exit; //拷贝... Result:=DoCopyDir(sDirName,sToDirName); end;---- 2、删除目录 ---- 删除目录与拷贝目录很类似,但为了能删除位于根目录下的一个空目录,需要在辅助函数中设置一个标志变量,即:如果删除的是空目录,则置bEmptyDir为True,这一句已经用深色框表示了。 ---- 2.1删除目录的递归辅助函数:DoRemoveDir function DoRemoveDir(sDirName:String):Boolean; var hFindFile:Cardinal; tfile:String; sCurDir:String; bEmptyDir:Boolean; FindFileData:WIN32_FIND_DATA; begin //如果删除的是空目录,则置bEmptyDir为True //初始时,bEmptyDir为True bEmptyDir:=True; //先保存当前目录 sCurDir:=GetCurrentDir; SetLength(sCurDir,Length(sCurDir)); ChDir(sDirName); hFindFile:=FindFirstFile('*.*',FindFileData); if hFindFile< >INVALID_HANDLE_VALUE then begin repeat tfile:=FindFileData.cFileName; if (tfile='.') or (tfile='..') then begin bEmptyDir:=bEmptyDir and True; Continue; end; //不是空目录,置bEmptyDir为False bEmptyDir:=False; if FindFileData.dwFileAttributes= FILE_ATTRIBUTE_DIRECTORY then begin if sDirName[Length(sDirName)]< >'\' then DoRemoveDir(sDirName+'\'+tfile) else DoRemoveDir(sDirName+tfile); if not RemoveDirectory(PChar(tfile)) then result:=false else result:=true; end else begin if not DeleteFile(PChar(tfile)) then result:=false else result:=true; end; until FindNextFile(hFindFile,FindFileData)=false; FindClose(hFindFile); end else begin ChDir(sCurDir); result:=false; exit; end; //如果是空目录,则删除该空目录 if bEmptyDir then begin //返回上一级目录 ChDir('..'); //删除空目录 RemoveDirectory(PChar(sDirName)); end; //回到原来的目录下 ChDir(sCurDir); result:=true; end;---- 2.2删除目录的函数:DeleteDir function DeleteDir(sDirName:String):Boolean; begin if Length(sDirName)< =0 then exit; //删除... Result:=DoRemoveDir(sDirName) and RemoveDir(sDirName); end;---- 3、移动目录 ---- 有了拷贝目录和删除目录的函数,移动目录就变得很简单,只需顺序调用前两个函数即可: function MoveDir(sDirName:String; sToDirName:string):Boolean; begin if CopyDir(sDirName,sToDirName) then if RemoveDir(sDirName) then result:=True else result:=false; end;/////////////////////////////////////////////// procedure TForm1.Button2Click(Sender: TObject); var OpStruc: TSHFileOpStruct; frombuf, tobuf: Array [0..128] of Char; Begin FillChar( frombuf, Sizeof(frombuf), 0 ); FillChar( tobuf, Sizeof(tobuf), 0 ); StrPCopy( frombuf, 'd:\brief\*.*' ); StrPCopy( tobuf, 'd:\temp\brief' ); With OpStruc DO Begin Wnd:= Handle; wFunc:= FO_COPY; pFrom:= @frombuf; pTo:=@tobuf; fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION; fAnyOperationsAborted:= False; hNameMappings:= Nil; lpszProgressTitle:= Nil; end; ShFileOperation( OpStruc ); end;
procedure Copy_Dir(SourceDirName,DestDirName: String); {*****复制文件夹及文件*****} ///uses IdGlobal; ///参数SourceDirName是源文件夹名,DestDirName是目标文件夹名。 var Current_Path: String; Sr: TSearchRec; begin Current_Path:= SourceDirName+'\*.*'; if not DirectoryExists(DestDirName) then CreateDir(DestDirName); if DirectoryExists(SourceDirName) then begin /////////Copy文件夹 if FindFirst(Current_Path,faDirectory,Sr)=0 then begin if (Sr.Attr and faDirectory)=Sr.Attr then if (Sr.Name<>'.')and(Sr.Name<>'..') then Copy_Dir(SourceDirName+'\'+Sr.Name,DestDirName+'\'+Sr.Name); While FindNext(sr)=0 do begin if (Sr.Attr and faDirectory)=Sr.Attr then if (Sr.Name<>'.')and(Sr.Name<>'..') then Copy_Dir(SourceDirName+'\'+Sr.Name,DestDirName+'\'+Sr.Name); end; FindClose(Sr); end; /////////Copy文件 if FindFirst(Current_Path, Sr.Attr, Sr)=0 then begin if (Sr.Attr and faAnyFile)=Sr.Attr then if (Sr.Name<>'.')and(Sr.Name<>'..') then CopyFileTo(SourceDirName+'\'+Sr.Name,DestDirName+'\'+Sr.Name); While FindNext(Sr)=0 do begin if (Sr.Attr and faAnyFile)=Sr.Attr then if (Sr.Name<>'.')and(Sr.Name<>'..') then CopyFileTo(SourceDirName+'\'+Sr.Name,DestDirName+'\'+Sr.Name); end; FindClose(Sr); end; end; end; procedure Delete_Dir(Dir_Name: String); {*****删除文件夹及文件*****} //参数Dir_Name为文件夹的路径 var Current_Path: String; Sr: TSearchRec; begin Current_Path:= Dir_Name+'\*.*'; if DirectoryExists(Dir_Name) then begin /////////删除文件夹 if FindFirst(Current_Path,faDirectory,Sr)=0 then begin if (Sr.Attr and faDirectory)=Sr.Attr then if (Sr.Name<>'.')and(Sr.Name<>'..') then Delete_Dir(Dir_Name+'\'+Sr.Name); While FindNext(sr)=0 do begin if (Sr.Attr and faDirectory)=Sr.Attr then if (Sr.Name<>'.')and(Sr.Name<>'..') then Delete_Dir(Dir_Name+'\'+Sr.Name); end; FindClose(Sr); end; /////////删除文件 if FindFirst(Current_Path, Sr.Attr, Sr)=0 then begin if (Sr.Attr and faAnyFile)=Sr.Attr then if (Sr.Name<>'.')and(Sr.Name<>'..') then DeleteFile(Dir_Name+'\'+Sr.Name); While FindNext(Sr)=0 do begin if (Sr.Attr and faAnyFile)=Sr.Attr then if (Sr.Name<>'.')and(Sr.Name<>'..') then DeleteFile(Dir_Name+'\'+Sr.Name); end; FindClose(Sr); end; RemoveDir(Dir_Name); end; end; delphi6+Windows2000/98下编译通过。
sToDirName:String):Boolean;
var
hFindFile:Cardinal;
t,tfile:String;
sCurDir:String[255];
FindFileData:WIN32_FIND_DATA;
begin
//先保存当前目录
sCurDir:=GetCurrentDir;
ChDir(sDirName);
hFindFile:=FindFirstFile('*.*',FindFileData);
if hFindFile< >INVALID_HANDLE_VALUE then
begin
if not DirectoryExists(sToDirName) then
ForceDirectories(sToDirName);
repeat
tfile:=FindFileData.cFileName;
if (tfile='.') or (tfile='..') then
Continue;
if FindFileData.dwFileAttributes=
FILE_ATTRIBUTE_DIRECTORY then
begin
t:=sToDirName+'\'+tfile;
if not DirectoryExists(t) then
ForceDirectories(t);
if sDirName[Length(sDirName)]< >'\' then
DoCopyDir(sDirName+'\'+tfile,t)
else
DoCopyDir(sDirName+tfile,sToDirName+tfile);
end
else
begin
t:=sToDirName+'\'+tFile;
CopyFile(PChar(tfile),PChar(t),True);
end;
until FindNextFile(hFindFile,FindFileData)=false;
FindClose(hFindFile);
end
else
begin
ChDir(sCurDir);
result:=false;
exit;
end;
//回到原来的目录下
ChDir(sCurDir);
result:=true;
end;---- 1.2拷贝目录的函数:CopyDir function CopyDir(sDirName:String;
sToDirName:string):Boolean;
begin
if Length(sDirName)< =0 then
exit;
//拷贝...
Result:=DoCopyDir(sDirName,sToDirName);
end;---- 2、删除目录 ---- 删除目录与拷贝目录很类似,但为了能删除位于根目录下的一个空目录,需要在辅助函数中设置一个标志变量,即:如果删除的是空目录,则置bEmptyDir为True,这一句已经用深色框表示了。 ---- 2.1删除目录的递归辅助函数:DoRemoveDir function DoRemoveDir(sDirName:String):Boolean;
var
hFindFile:Cardinal;
tfile:String;
sCurDir:String;
bEmptyDir:Boolean;
FindFileData:WIN32_FIND_DATA;
begin
//如果删除的是空目录,则置bEmptyDir为True
//初始时,bEmptyDir为True
bEmptyDir:=True;
//先保存当前目录
sCurDir:=GetCurrentDir;
SetLength(sCurDir,Length(sCurDir));
ChDir(sDirName);
hFindFile:=FindFirstFile('*.*',FindFileData);
if hFindFile< >INVALID_HANDLE_VALUE then
begin
repeat
tfile:=FindFileData.cFileName;
if (tfile='.') or (tfile='..') then
begin
bEmptyDir:=bEmptyDir and True;
Continue;
end;
//不是空目录,置bEmptyDir为False
bEmptyDir:=False;
if FindFileData.dwFileAttributes=
FILE_ATTRIBUTE_DIRECTORY then
begin
if sDirName[Length(sDirName)]< >'\' then
DoRemoveDir(sDirName+'\'+tfile)
else
DoRemoveDir(sDirName+tfile);
if not RemoveDirectory(PChar(tfile)) then
result:=false
else
result:=true;
end
else
begin
if not DeleteFile(PChar(tfile)) then
result:=false
else
result:=true;
end;
until FindNextFile(hFindFile,FindFileData)=false;
FindClose(hFindFile);
end
else
begin
ChDir(sCurDir);
result:=false;
exit;
end;
//如果是空目录,则删除该空目录
if bEmptyDir then
begin
//返回上一级目录
ChDir('..');
//删除空目录
RemoveDirectory(PChar(sDirName));
end; //回到原来的目录下
ChDir(sCurDir);
result:=true;
end;---- 2.2删除目录的函数:DeleteDir function DeleteDir(sDirName:String):Boolean;
begin
if Length(sDirName)< =0 then
exit;
//删除...
Result:=DoRemoveDir(sDirName) and RemoveDir(sDirName);
end;---- 3、移动目录 ---- 有了拷贝目录和删除目录的函数,移动目录就变得很简单,只需顺序调用前两个函数即可: function MoveDir(sDirName:String;
sToDirName:string):Boolean;
begin
if CopyDir(sDirName,sToDirName) then
if RemoveDir(sDirName) then
result:=True
else
result:=false;
end;///////////////////////////////////////////////
procedure TForm1.Button2Click(Sender: TObject);
var
OpStruc: TSHFileOpStruct;
frombuf, tobuf: Array [0..128] of Char;
Begin
FillChar( frombuf, Sizeof(frombuf), 0 );
FillChar( tobuf, Sizeof(tobuf), 0 );
StrPCopy( frombuf, 'd:\brief\*.*' );
StrPCopy( tobuf, 'd:\temp\brief' );
With OpStruc DO Begin
Wnd:= Handle;
wFunc:= FO_COPY;
pFrom:= @frombuf;
pTo:=@tobuf;
fFlags:= FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
fAnyOperationsAborted:= False;
hNameMappings:= Nil;
lpszProgressTitle:= Nil; end;
ShFileOperation( OpStruc );
end;
{*****复制文件夹及文件*****}
///uses IdGlobal;
///参数SourceDirName是源文件夹名,DestDirName是目标文件夹名。
var
Current_Path: String;
Sr: TSearchRec;
begin
Current_Path:= SourceDirName+'\*.*';
if not DirectoryExists(DestDirName) then
CreateDir(DestDirName);
if DirectoryExists(SourceDirName) then
begin
/////////Copy文件夹
if FindFirst(Current_Path,faDirectory,Sr)=0 then
begin
if (Sr.Attr and faDirectory)=Sr.Attr then
if (Sr.Name<>'.')and(Sr.Name<>'..') then
Copy_Dir(SourceDirName+'\'+Sr.Name,DestDirName+'\'+Sr.Name);
While FindNext(sr)=0 do
begin
if (Sr.Attr and faDirectory)=Sr.Attr then
if (Sr.Name<>'.')and(Sr.Name<>'..') then
Copy_Dir(SourceDirName+'\'+Sr.Name,DestDirName+'\'+Sr.Name);
end;
FindClose(Sr);
end;
/////////Copy文件
if FindFirst(Current_Path, Sr.Attr, Sr)=0 then
begin
if (Sr.Attr and faAnyFile)=Sr.Attr then
if (Sr.Name<>'.')and(Sr.Name<>'..') then
CopyFileTo(SourceDirName+'\'+Sr.Name,DestDirName+'\'+Sr.Name);
While FindNext(Sr)=0 do
begin
if (Sr.Attr and faAnyFile)=Sr.Attr then
if (Sr.Name<>'.')and(Sr.Name<>'..') then
CopyFileTo(SourceDirName+'\'+Sr.Name,DestDirName+'\'+Sr.Name);
end;
FindClose(Sr);
end;
end;
end;
procedure Delete_Dir(Dir_Name: String);
{*****删除文件夹及文件*****}
//参数Dir_Name为文件夹的路径
var
Current_Path: String;
Sr: TSearchRec;
begin
Current_Path:= Dir_Name+'\*.*';
if DirectoryExists(Dir_Name) then
begin
/////////删除文件夹
if FindFirst(Current_Path,faDirectory,Sr)=0 then
begin
if (Sr.Attr and faDirectory)=Sr.Attr then
if (Sr.Name<>'.')and(Sr.Name<>'..') then
Delete_Dir(Dir_Name+'\'+Sr.Name);
While FindNext(sr)=0 do
begin
if (Sr.Attr and faDirectory)=Sr.Attr then
if (Sr.Name<>'.')and(Sr.Name<>'..') then
Delete_Dir(Dir_Name+'\'+Sr.Name);
end;
FindClose(Sr);
end;
/////////删除文件
if FindFirst(Current_Path, Sr.Attr, Sr)=0 then
begin
if (Sr.Attr and faAnyFile)=Sr.Attr then
if (Sr.Name<>'.')and(Sr.Name<>'..') then
DeleteFile(Dir_Name+'\'+Sr.Name);
While FindNext(Sr)=0 do
begin
if (Sr.Attr and faAnyFile)=Sr.Attr then
if (Sr.Name<>'.')and(Sr.Name<>'..') then
DeleteFile(Dir_Name+'\'+Sr.Name);
end;
FindClose(Sr);
end;
RemoveDir(Dir_Name);
end;
end;
delphi6+Windows2000/98下编译通过。