mbshareat
چهارشنبه 04 اردیبهشت 1398, 17:36 عصر
سلام
میخوام یه بک آپ از شاخه های موجود در پوشه جاری در 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.
میخوام یه بک آپ از شاخه های موجود در پوشه جاری در 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.