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.

TTask.Run()