uses StrUtils;
procedure IncrementalBackup(SrcDir, DestDir:
string; ErrorLog: TStrings;
CopyEmptyDirs: Boolean = false);
procedure Log(
const Msg:
string);
begin
if Assigned(ErrorLog)
then
ErrorLog.Add(Msg);
end;
const
faNewAnyFileEx = $00017FFF;
// erweitertes faAnyFile aus der DP
INVALID_DIRS =
'
Zielverzeichnis darf nicht im Quellverzeichnis enthalten sein';
var
SearchRec: TSearchRec;
DestPath:
string;
AttrCode: integer;
begin
if AnsiContainsText(SrcDir, DestDir)
then
raise Exception.Create(INVALID_DIRS);
SrcDir := IncludeTrailingPathDelimiter(SrcDir);
DestDir := IncludeTrailingPathDelimiter(DestDir);
if FindFirst(SrcDir + '
*.*', faNewAnyFileEx, SearchRec) = 0
then
try
repeat
if (SearchRec.
Name <> '
.')
and (SearchRec.
Name <> '
..')
then
begin
// Verzeichnis gefunden
if (SearchRec.Attr
and faDirectory) = faDirectory
then
begin
DestPath := DestDir + SearchRec.
Name;
// ggf. anlegen
if CopyEmptyDirs
then
begin
if not(DirectoryExists(DestPath)
or
ForceDirectories(DestPath))
then
Log(DestPath + '
konnte nicht angelegt werden.');
end;
// Rekursiver Aufruf
IncrementalBackup(SrcDir + SearchRec.
Name, DestPath, ErrorLog,
CopyEmptyDirs);
end
// Datei gefunden
else
begin
DestPath := DestDir + ExtractFilename
(ExcludeTrailingPathDelimiter(SrcDir));
// nur bei gesetztem Archiv-Attribut oder wenn nicht vorhanden
if ((SearchRec.Attr
and faArchive) = faArchive)
or
not FileExists(DestDir + SearchRec.
Name)
then
begin
// Zielverzeichnis ggf. anlegen
if not(DirectoryExists(DestPath)
or
ForceDirectories(DestPath))
then
Log(DestPath + '
konnte nicht angelegt werden.')
else
begin
// Datei kopieren
if not CopyFile(PChar(SrcDir + SearchRec.
Name),
PChar(DestPath + SearchRec.
Name), false)
then
Log(Format('
%s: %s', [DestPath + SearchRec.
Name,
SysErrorMessage(GetLastError)]))
// bei Erfolg Archiv-Attribut entfernen
else
begin
AttrCode := FileSetAttr(SrcDir + SearchRec.
Name,
SearchRec.Attr
and not faArchive);
if AttrCode <> 0
then
Log(Format('
%s: %s', [DestPath + SearchRec.
Name,
SysErrorMessage(AttrCode)]));
end;
end;
end;
end;
end;
until FindNext(SearchRec) <> 0;
finally
SysUtils.FindClose(SearchRec);
end;
end;