盒子论坛 v2.1

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ComCtrls, StdCtrls;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    Edit2: TEdit;
    Button1: TButton;
    Label3: TLabel;
    Label4: TLabel;
    ProgressBar1: TProgressBar;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    function CopyDir(sDirName:String;sToDirName:string):Boolean;
     function DoCopyDir(sDirName:String;sToDirName:String):Boolean;
  end;

var
  Form1: TForm1;

implementation
{$R *.dfm}

function TForm1.CopyDir(sDirName:String;sToDirName:string):Boolean;
begin
if Length(sDirName)<=0  then
   exit;
//拷贝...
Result:=DoCopyDir(sDirName,sToDirName);
end;

function TForm1.DoCopyDir(sDirName:String;sToDirName:String):Boolean;
  var
    sr:TsearchRec;
    hFindFile:Cardinal;
    t,tfile :String;
    sCurDir:String[255];
    FindFileData:WIN32_FIND_DATA;
    Attrs:Integer;
  begin
  //先保存当前目录
    sCurDir:=GetCurrentDir;
    try
    ChDir(sDirName);//改变当前目录为‘SDirName’
    except
    exit;
    end;
     //showmessage(sdirname);
    hFindFile:=FindFirstfile('*.*',FindFileData);//把找到的第一个文件赋给hfindFile
    if hFindFile<>INVALID_HANDLE_VALUE  then
      begin
      ProgressBar1.Position :=ProgressBar1.Position +1;
        if not DirectoryExists(sToDirName) then
          ForceDirectories(sToDirName); //判断目标目录是否存在，如果不存在，则创建该多级目录
        repeat
          tfile :=FindFileData.cFileName; //搜索所在目录下的所有文件
          if (tfile='.') or (tfile='..')then
            Continue;
          if (FindFileData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY)>0 then
            begin
              t:=sToDirName+'\'+tfile;


              if not DirectoryExists(t) then
                ForceDirectories(t); //判断目录是否存在，如果没有则建立目录
              //if sDirName[Length(sDirName)]<>'\' then
               // begin
                DoCopyDir(sDirName+'\'+tfile,t);//如果路径后不带'\'，则需加上
                 Attrs:=FileGetAttr(sDirName+'\'+tfile);
                 FileSetAttr(t,Attrs);
                // end
             // else
               // begin
               // DoCopyDir(sDirName+tfile,sToDirName+tfile);
               //  Attrs:=FileGetAttr(sDirName+tfile);
               //  FileSetAttr(t,Attrs);
             //    end;
            end
          else
            begin
                t:=sToDirName+'\'+tFile;
                CopyFile(PChar(tfile),PChar(t),True);
            end;
         Label4.Caption :=t;
         Label4.Update ;
         until FindNextFile(hFindFile,FindFileData)=false;
           //FindClose(hFindFile);
      end
    else
      begin
        ChDir(sCurDir);
        result:=false;
        exit;
      end;
  //回到原来的目录下
  ChDir(sCurDir);
  result:=true;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ProgressBar1.Max:=1000;
ProgressBar1.Position :=0;
if CopyDir(edit1.Text ,edit2.Text ) then
begin//1
  Showmessage('拷贝目录完成');

end;//1
ProgressBar1.Position :=0;
end;

end.

----------------------------------------------

作者：

heihei_76 (小黑)	★☆☆☆☆	-
	盒子活跃会员

2004/1/6 9:25:36

2楼：

uses shellapi;
procedure dircopy(ahandle:Thandle;afromdir,atodir:string);
var
  shfileopstruct:Tshfileopstruct;
  fromdir:pchar;
  todir:pchar;
begin
getmem(fromdir,length(afromdir)+2);
try
   getmem(todir,length(atodir)+2);
   try
     fillchar(fromdir^,length(afromdir)+2,0);
     fillchar(todir^,length(atodir)+2,0);
     strcopy(fromdir,pchar(afromdir));
     strcopy(todir,pchar(atodir));
     with shfileopstruct do
     begin
      wnd:=ahandle;
      wfunc:=fo_copy;
      pfrom:=fromdir;
      pto:=todir;
      fflags:=fof_noconfirmation or fof_renameoncollision;
      fanyoperationsaborted:=false;
      hnamemappings:=nil;
      lpszprogresstitle:=nil;
     end;
      shfileoperation(shfileopstruct);
   finally
     freemem(todir,length(atodir)+2);
   end;
finally
freemem(fromdir,length(afromdir)+2);
end;
end;
----------------------------------------------
-

﹗﹗﹗

信息

登陆以后才能回复