unit uMyBackup;
interface
uses
Winapi.Windows,
Winapi.Messages, System.SysUtils, System.Variants,
System.Classes,
Vcl.Graphics,
Vcl.Controls,
Vcl.Forms,
Vcl.Dialogs, ZipForge,
Vcl.ExtCtrls,
Vcl.ComCtrls,
Vcl.StdCtrls, System.SyncObjs;
type
TFrmMyDelphiBackup =
class(TForm)
StatusBar: TStatusBar;
Panel1: TPanel;
BtnStart: TButton;
ZipForge1: TZipForge;
lvZipList: TListView;
procedure FormShow(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure BtnStartClick(Sender: TObject);
procedure ZipperOverallProgress(Sender: TObject; Progress: Double; Operation: TZFProcessOperation;
ProgressPhase: TZFProgressPhase;
var Cancel: Boolean);
procedure ZipForge1ProcessFileFailure(Sender: TObject; FileName:
string; Operation: TZFProcessOperation;
NativeError, ErrorCode: Integer; ErrorMessage:
string;
var Action: TZFAction);
private
{ Private-Deklarationen }
FMaxThreads: Integer;
FTempStrings: TStrings;
FApplicationBaseDir:
string;
FCritSection: TCriticalSection;
function IniFileName:
string;
function IniLesen: Boolean;
procedure IniSchreiben;
procedure LogSchreiben;
public
{ Public-Deklarationen }
procedure StatusMessage(aValue:
string);
procedure StringListToListView(
const aItems: TStrings);
procedure FileListZippen(aID: Integer;
const aZipFileName:
string;
const aZipperBaseDir:
string;
const aZipFileMask:
string);
end;
var
FrmMyDelphiBackup: TFrmMyDelphiBackup;
implementation
{$R *.dfm}
uses System.Threading, System.IOUtils, System.StrUtils, System.IniFiles;
const
cCrLf = #13#10;
cCrLf2 = cCrLf + cCrLf;
cMaxThreadsDefault = 4;
resourcestring
rsAppName = '
Mein kleines Zip-Backup';
rsTrennChar = '
# ';
{ -Ini-File- }
rsIniName = '
BackupZipper-Einstellungen.ini';
rsSectionSettings = '
Einstellungen';
rsSectionObjectList = '
Objekt-Liste';
rsSectionObjectChecked = '
Objekt-Auswahl';
rsAppBaseDir = '
Arbeitsverzeichnis';
rsMaxThreads = '
MaxThreads';
{ -Messages- }
rsAppBaseDirCreate = '
Das Verzeichnis ' + cCrLf2 + '
%s' + cCrLf2 + '
ist nicht vorhanden. Soll es neu angelegt werden?';
rsInvalidPath = '
Unzulässige Pfadangabe! Das zu sichernde Verzeichnis' + cCrLf2 + '
%s ' + cCrLf2 +
'
darf nicht im Arbeitsverzeichnis' + cCrLf2 + '
%s ' + cCrLf2 +
'
enthalten sein! Die erzeugtren ZIP-Dateien würden sich zur Laufzeit selber ' + '
sichern, und das geht nicht!';
rsNoDirectory = '
Das Verzeichnis %s ist nicht vorhanden!';
var
ThreadCount: Integer = -1;
ThreadID: Integer = 0;
{ ------------------------------------------------------------------------------ }
{ - Formular-Events ------------------------------------------------------------ }
{ ------------------------------------------------------------------------------ }
procedure TFrmMyDelphiBackup.FormShow(Sender: TObject);
begin
FCritSection := TCriticalSection.Create;
FTempStrings := TStringList.Create;
FMaxThreads := cMaxThreadsDefault;
if IniLesen
then
begin
if Pos('
:', FApplicationBaseDir) = 2
then
begin
if not DirectoryExists(FApplicationBaseDir)
then
begin
if MessageBox(
Handle, PChar(Format(rsAppBaseDirCreate, [FApplicationBaseDir])), PChar(rsAppName),
MB_YESNO + MB_ICONQUESTION) = IDYES
then
ForceDirectories(FApplicationBaseDir)
else
Close;
end
else
begin
StringListToListView(FTempStrings);
FTempStrings.Clear;
StatusMessage('
Programmstart mit maximal ' + FMaxThreads.ToString + '
Threads');
end;
end
else
Close;
end;
end;
procedure TFrmMyDelphiBackup.FormDestroy(Sender: TObject);
begin
FCritSection.Free;
FTempStrings.Free;
IniSchreiben;
end;
{ ------------------------------------------------------------------------------ }
{ - Component-Events ----------------------------------------------------------- }
{ ------------------------------------------------------------------------------ }
procedure TFrmMyDelphiBackup.BtnStartClick(Sender: TObject);
var
Ix, TimeStamp: Integer;
function GetZipFileName(aPraefix:
string):
string;
begin
Result := aPraefix + '
-' + IntToStr(TimeStamp) + '
.zip';
end;
begin
BtnStart.Enabled := false;
ThreadCount := 0;
TimeStamp := DateTimeToFileDate(Now);
for Ix := 0
to Pred(lvZipList.Items.Count)
do
begin
if lvZipList.Items[Ix].Checked
then
begin
lvZipList.ItemIndex := Ix;
FileListZippen(Ix, GetZipFileName(lvZipList.Items[Ix].SubItems[0]), FApplicationBaseDir, lvZipList.Items[Ix].SubItems[1]);
end;
end;
end;
procedure TFrmMyDelphiBackup.ZipForge1ProcessFileFailure(Sender: TObject; FileName:
string; Operation: TZFProcessOperation;
NativeError, ErrorCode: Integer; ErrorMessage:
string;
var Action: TZFAction);
var
x: Integer;
begin
Action := fxaAbort;
FCritSection.Enter;
TThread.Queue(
nil,
procedure
begin
x := (Sender
as TZipForge).Tag;
StatusMessage('
Thread Nr. ' + x.ToString + '
ZIP-Fehler bei ' + FileName);
StatusMessage('
ErrorMessage: ' + ErrorMessage);
end);
FCritSection.Leave;
end;
procedure TFrmMyDelphiBackup.ZipperOverallProgress(Sender: TObject; Progress: Double; Operation: TZFProcessOperation;
ProgressPhase: TZFProgressPhase;
var Cancel: Boolean);
var
x: Integer;
begin
case ProgressPhase
of
ppStart:
begin
FCritSection.Enter;
TThread.Synchronize(
nil,
procedure
begin
x := (Sender
as TZipForge).Tag;
StatusMessage('
Thread Nr. ' + x.ToString + '
ZIP-Vorgang gestartet');
end);
FCritSection.Leave;
end;
ppProcess:
begin
if Progress > 99.0
then
Progress := 100;
FCritSection.Enter;
TThread.Queue(
nil,
procedure
begin
x := (Sender
as TZipForge).Tag;
lvZipList.Items[x].SubItems[2] := IntToStr(Trunc(Progress)) + '
%';
end);
FCritSection.Leave;
end;
ppEnd:
begin
FCritSection.Enter;
TThread.Synchronize(
nil,
procedure
begin
Dec(ThreadCount);
x := (Sender
as TZipForge).Tag;
StatusMessage('
Thread Nr. ' + x.ToString + '
beendet');
end);
FCritSection.Leave;
end;
end;
end;
{ ------------------------------------------------------------------------------ }
{ - Private-Deklarationen ------------------------------------------------------ }
{ ------------------------------------------------------------------------------ }
function TFrmMyDelphiBackup.IniFileName:
string;
begin
Result := TPath.Combine(TPath.GetDocumentsPath, rsIniName);
end;
function TFrmMyDelphiBackup.IniLesen: Boolean;
var
i: Integer;
Value, Dir:
string;
begin
Result := false;
if not FileExists(IniFileName)
then
with TIniFile.Create(IniFileName)
do
try // Standardwerte eintragen
WriteString(rsSectionSettings, rsAppBaseDir, TPath.GetDocumentsPath);
WriteString(rsSectionObjectList, '
Ini-File', IniFileName);
finally
Free;
end;
with TIniFile.Create(IniFileName)
do
try
FMaxThreads := ReadInteger(rsSectionSettings, rsMaxThreads, cMaxThreadsDefault);
FApplicationBaseDir := ReadString(rsSectionSettings, rsAppBaseDir, TPath.GetDocumentsPath);
ReadSection(rsSectionObjectList, FTempStrings);
for i := Pred(FTempStrings.Count)
downto 0
do
begin
Value := ReadString(rsSectionObjectList, FTempStrings[i], '
');
Dir := ExtractFileDir(Value);
if StartsText(Dir, FApplicationBaseDir)
then
begin
ShowMessage(Format(rsInvalidPath, [Dir, FApplicationBaseDir]));
FTempStrings.Delete(i)
end
else
begin
if DirectoryExists(Dir)
then
FTempStrings[i] := FTempStrings[i] + rsTrennChar + Value
else
begin
ShowMessage(Format(rsNoDirectory, [Dir]));
FTempStrings.Delete(i);
end;
end;
end;
finally
Free;
end;
Result := FTempStrings.Count > 0;
end;
procedure TFrmMyDelphiBackup.IniSchreiben;
var
i: Integer;
begin
with TIniFile.Create(IniFileName)
do
try
for i := 0
to Pred(lvZipList.Items.Count)
do
WriteBool(rsSectionObjectChecked, lvZipList.Items[i].SubItems[0], lvZipList.Items[i].Checked);
finally
Free;
end;
end;
procedure TFrmMyDelphiBackup.LogSchreiben;
begin
if FTempStrings.Count > 0
then
FTempStrings.SaveToFile(ChangeFileExt(IniFileName, '
.log'));
end;
{ ------------------------------------------------------------------------------ }
{ - Public-Deklarationen ------------------------------------------------------- }
{ ------------------------------------------------------------------------------ }
procedure TFrmMyDelphiBackup.StatusMessage(aValue:
string);
begin
StatusBar.Panels[0].Text := TimeToStr(Now);
StatusBar.Panels[1].Text := aValue;
FTempStrings.Add(StatusBar.Panels[0].Text + rsTrennChar + StatusBar.Panels[1].Text);
end;
procedure TFrmMyDelphiBackup.StringListToListView(
const aItems: TStrings);
var
Item: TListItem;
i, p: Integer;
Ini: TIniFile;
begin
Ini := TIniFile.Create(IniFileName);
try
for i := 0
to Pred(aItems.Count)
do
begin
p := Pos(rsTrennChar, aItems[i]);
Item := lvZipList.Items.Add;
Item.Caption := IntToStr(i + 1);
Item.SubItems.Add(copy(aItems[i], 1, p - 1));
p := p + Length(rsTrennChar);
Item.SubItems.Add(copy(aItems[i], p, Length(aItems[i])));
Item.SubItems.Add('
-');
Item.Checked := Ini.ReadBool(rsSectionObjectChecked, Item.SubItems[0], false);
end;
finally
Ini.Free;
end;
end;
procedure TFrmMyDelphiBackup.FileListZippen(aID: Integer;
const aZipFileName:
string;
const aZipperBaseDir:
string;
const aZipFileMask:
string);
begin
{ -warten, falls MaxThreads überschritten- }
if ThreadCount > FMaxThreads
then
begin
StatusMessage('
Thread-ID(' + aID.ToString + '
) warte auf nächsten Thread...');
while ThreadCount > FMaxThreads
do
begin
Sleep(10);
Application.ProcessMessages;
end;
end;
{ -Task starten- }
StatusMessage('
Thread-ID(' + aID.ToString + '
) [' + aZipFileMask + '
] gestartet');
TTask.Run(
procedure
var
LZipper: TZipForge;
begin
Inc(ThreadCount);
LZipper := TZipForge.Create(Application);
try
LZipper.Tag := aID;
LZipper.OnOverallProgress := ZipperOverallProgress;
LZipper.Zip64Mode := zmAuto;
LZipper.BaseDir := aZipperBaseDir;
LZipper.FileName := TPath.Combine(aZipperBaseDir, aZipFileName);
LZipper.OpenArchive(fmCreate);
try
LZipper.AddFiles(aZipFileMask);
except
on E:
Exception do
begin
FCritSection.Enter;
TThread.Synchronize(
nil,
procedure
begin
Dec(ThreadCount);
StatusMessage('
Thread Nr. ' + aID.ToString + '
Exception: ' + E.
Message);
end);
FCritSection.Leave;
end;
end;
LZipper.CloseArchive;
finally
LZipper.Free;
end;
end);
end;
end.