بک آپ گرفتن از زیر شاخه ها

[mbshareat]

سلام
میخوام یه بک آپ از شاخه های موجود در پوشه جاری در myDocument بگیرم.
چند تا کد دارم که کمی دستکاریش کردم.
نمی دونم چرا بار اول که برنامه رو اجرا می کنم،درست کار می کنه ولی بار دوم و سوم عجیب کار می کنه.
مثلا یه پوشه داخلی دارم به نام A.بار اول که برنامه رو اجرا می کنم درست کپی می کنه(BackUp\A).اما بار دوم یه زیر شاخه هم داخل A میسازه(BackUp\A\A).
ممکنه کد رو یه نگاه کنید برام اصلاح کنید؟

unit EasyBackupUnit;



interface



uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, FileCtrl, StdCtrls,ShellApi,ShlObj,ActiveX,StrUtils;



type

  TForm1 = class(TForm)

    procedure FormCreate(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

  end;



var

  Form1: TForm1;

  Dirs:Array[1..32000] of String;

  DirsNo:Word=0;





implementation



{$R *.dfm}

function CopyDir(const fromDir, toDir: string): Boolean;

var

  fos: TSHFileOpStruct;

begin

  ZeroMemory(@fos, SizeOf(fos));

  with fos do

  begin

    wFunc  := FO_COPY;

    fFlags := FOF_FILESONLY;

    pFrom  := PChar(fromDir + #0);

    pTo    := PChar(toDir)

  end;

  Result := (0 = ShFileOperation(fos));

end;

procedure GetDirs(const sRootDir:string;OnlyMainDir:Boolean);

var

  srSearch: TSearchRec;

  sSearchPath: string;

  sltSub: TStrings;

  i: Integer;

begin

  sltSub := TStringList.Create;

  try

    sSearchPath := IncludeTrailingBackslash(sRootDir);

    if FindFirst(sSearchPath + '*', faDirectory, srSearch) = 0 then

      repeat

        if (srSearch.Name <> '.') and

          (srSearch.Name <> '..') then

        begin

          if ((srSearch.Attr and faDirectory) =faDirectory) then

          Begin

            Inc(DirsNo);

            Dirs[DirsNo]:=sSearchPath + srSearch.Name;

          End;

          sltSub.Add(sSearchPath + srSearch.Name);

        end;

      until (FindNext(srSearch) <> 0);



    FindClose(srSearch);

    if OnlyMainDir=false then

    Begin

      for i := 0 to sltSub.Count - 1 do

        GetDirs(sltSub.Strings[i],OnlyMainDir);

    End;

  finally

    FreeAndNil(sltSub);

  end;

end;

function MyDocumentPath: string;

var

  Allocator: IMalloc;

  SpecialDir: PItemIdList;

  FBuf: array[0..MAX_PATH] of Char;

  PerDir: string;

begin

  if SHGetMalloc(Allocator) = NOERROR then

  begin

    SHGetSpecialFolderLocation(Form1.Handle, CSIDL_PERSONAL, SpecialDir);

    SHGetPathFromIDList(SpecialDir, @FBuf[0]);

    Allocator.Free(SpecialDir);

    Result:=string(FBuf);

  end;

end;

procedure TForm1.FormCreate(Sender: TObject);

Var

  I,J:SmallInt;

  F1,F2:String;

begin

  GetDirs(ExtractFileDir(Application.ExeName),true);

  ForceDirectories(MyDocumentPath+'\Backup');

  For I:=1 to DirsNo do

  Begin

    //ShowMessage(Dirs[I]+#13+MyDocumentPath+'\Backup\'+ExtractFileName(Dir  s[I]));

    CopyDir(Dirs[I],MyDocumentPath+'\Backup\'+ExtractFileName(Dirs[I]));

  End;

  Application.Terminate;

end;



end.