بک آپ گرفتن از زیر شاخه ها
سلام
میخوام یه بک آپ از شاخه های موجود در پوشه جاری در 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.
نقل قول: بک آپ گرفتن از زیر شاخه ها
چند تا کد کپی شاخه رو امتحان کردم بعضیها کار نکردند وچند تاشون همینطوری کار کردند.مجبور شدم کد حذف شاخه قبل از کپی بذارم.
نقل قول: بک آپ گرفتن از زیر شاخه ها
نقل قول:
نوشته شده توسط
mbshareat
سلام
میخوام یه بک آپ از شاخه های موجود در پوشه جاری در myDocument بگیرم.
end.[/PASCAL]
سلام
منظورت فقط پوشه های موجود در مسیر جاریه یا شامل فایل هم میشه؟
نقل قول: بک آپ گرفتن از زیر شاخه ها
زیر شاخه ها رو هم میخواستم کپی بگیرم.چون در واقع نتیجه نهایی دستکاری فایلها رو میخوام.
نقل قول: بک آپ گرفتن از زیر شاخه ها
نیازی به این کد پیچیده نیست و میتوانید این کار را با روتینهای موجود در یونتی IOUtils انجام دهید.