[Dmitry36]

Добрый день, уважаемые форумчане!!

стояла следующая задача:
архивировать дифференциальные Бэкапы БД, каждые 4 часа.

решение:
написал приложение которое работает с компонентом zipforge, пакует все отлично (без сбоев) сжимает конечно не по максимуму, но вполне удовлетворяет.

ближе к делу:
при выполнении архивации возникает проблема: программа зависает до полного её выполнения, пользователю непонятно что в реальное время происходит в ней и за частую делают вывод, что она висит, пытался использовать отдельный паток для архивации, но не вышло (моя безграмотность), нашел простой выход из ситуации "Application.ProcessMessages", но после этого основной код программы выполняется несколько раз, а это неприемлемо.Ниже привожу код, подскажите плс решение данной ситуации.

Код:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, ZipForge, RzPrgres, StdCtrls, RzLstBox, RzButton, RzEdit,
RzBckgnd;

type
TForm1 = class(TForm)
RzSeparator2: TRzSeparator;
RzSeparator1: TRzSeparator;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
RzMemo1: TRzMemo;
RzButton1: TRzButton;
ListBox1: TRzListBox;
Panel1: TPanel;
ZipForge1: TZipForge;
Timer1: TTimer;
RzProgressBar1: TRzProgressBar;
Function MoveFOLDERS():boolean;
Function ScanDir(StartDir: string; Mask: string; List: TStrings):boolean;
function MyRemoveDir(sDir : string) : Boolean;
procedure RzButton1Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure ZipForge1OverallProgress(Sender: TObject; Progress: Double;
Operation: TZFProcessOperation; ProgressPhase: TZFProgressPhase;
var Cancel: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
//========================================= поток ============================
//TMyThread = class(TThread)
// private
// { Private declarations }
//protected
// procedure Execute; override;
//end;
//================================================== ==========================
var
Form1: TForm1;
//MyThread: TMyThread;
DateSTR: string;
implementation

{$R *.dfm}

//procedure TMyThread.Execute;
//begin
//MyThread:=TMyThread.Create(False);
//Параметр False запускает поток сразу после создания, True - запуск впоследствии , методом Resume
//Далее можно указать параметры потока, например приоритет:
// MyThread.Priority:=tpHighest;
//Здесь описывается код, который будет выполняться в потоке

//end;

procedure TForm1.FormShow(Sender: TObject);
begin
Timer1.Enabled:=true;
end;

function TForm1.MoveFOLDERS: boolean;
begin
//------- rename dir
DateSTR:= 'E:\BACKUP(DIFF)\SQL_WMS_'+FormatDateTime('dd-mm-yyyy', Date)
+'('+(FormatDateTime('hh-mm',now-4/24)+'_'+FormatDateTime('hh-mm', now)+')');
RenameFile('E:\BACKUP(DIFF)\SQL_WMS',DateSTR);
//------- create dir
if not DirectoryExists('E:\BACKUP(DIFF)\SQL_WMS') then
ForceDirectories('E:\BACKUP(DIFF)\SQL_WMS');
result:=true;
end;

function TForm1.MyRemoveDir(sDir: string): Boolean;
var
iIndex: Integer;
SearchRec: TSearchRec;
sFileName: string;
begin
Result := False;
sDir := sDir + '\*.*';
iIndex := FindFirst(sDir, faAnyFile, SearchRec);

while iIndex = 0 do
begin
sFileName := ExtractFileDir(sDir)+'\'+SearchRec.name;
if SearchRec.Attr = faDirectory then
begin
if (SearchRec.name <> '' ) and (SearchRec.name <> '.') and
(SearchRec.name <> '..') then
MyRemoveDir(sFileName);
end
else
begin
if SearchRec.Attr <> faArchive then
FileSetAttr(sFileName, faArchive);
if not DeleteFile(sFileName) then
ShowMessage('Could NOT delete ' + sFileName);
end;
iIndex := FindNext(SearchRec);
end;

FindClose(SearchRec);
RemoveDir(ExtractFileDir(sDir));
Result := True;
end;

procedure TForm1.RzButton1Click(Sender: TObject);
var flag:boolean;
a:Byte;
symbol,files,DelDIRS,DelFILE:string;
begin
label3.caption:='ИДЕТ АРХИВАЦИЯ - НЕВЫКЛЮЧАТЬ !!!';
flag:=MoveFOLDERS;
RzMemo1.Clear;
//------------- ПЕРЕМЕЩЕНИЕ ПАПКИ
RzMemo1.Lines.Add('переименование директории:');
RzMemo1.Lines.Add(' "E:\BACKUP(DIFF)\SQL_WMS"');
RzMemo1.Lines.Add('');
RzMemo1.Lines.Add('переименование диретории:');
RzMemo1.Lines.Add(' "'+DateSTR+'"');
RzMemo1.Lines.Add('-----');

RzMemo1.Lines.Add('создание новой директории:');
RzMemo1.Lines.Add(' "E:\BACKUP(DIFF)\SQL_WMS"');
RzMemo1.Lines.Add('');
RzMemo1.Lines.Add('-----');
//------------- АРХЦИВАЦИЯ
RzMemo1.Lines.Add('Создание архива:');
RzMemo1.Lines.Add(' "'+DateSTR+'"');
RzMemo1.Lines.Add('-----');
ListBox1.Items.Clear;
ScanDir(DateSTR,'', ListBox1.Items);

if ListBox1.Items.Count > 0 then
with ZipForge1 do
begin
BaseDir := DateSTR;
FileName:=DateSTR+'.zip';
OpenArchive(fmCreate);
AddFiles('*.*');
try
TestFiles('*.*');
except
MessageDlg('Errors occurred in the archive file',mtError,[mbOk],0);
end;
CloseArchive;
end;
//------------- ЧИСТИМ ХЛАМ (5 дней ранее и более)

DelFILE:='E:\BACKUP(FULL)\SQL_WMS\FULL_PRD1_'+Form atDateTime('dd.mm.yyyy', Date-5)
+'_0-0.bak';
if FileExists(DelFILE) then DeleteFile(DelFILE);

DelFILE:='E:\BACKUP(FULL)\SQL_WMS\FULL_PRD1_'+Form atDateTime('dd.mm.yyyy', Date-5)
+'14_-0.bak';
if FileExists(DelFILE) then DeleteFile(DelFILE);


label3.caption:='АРХИВАЦИЯ BACKUP (*.zip)';
//================================================== ===========================
Try if RzProgressBar1.Percent = 100 then
begin
if not MyRemoveDir(DateSTR) then
ShowMessage('Что-то непошло "Проверить удаление"');
end;
except

End;
//================================================== ===========================
end;

function TForm1.ScanDir(StartDir, Mask: string; List: TStrings): boolean;
var
SearchRec: TSearchRec;
begin
if Mask = '' then Mask := '*.*';
if StartDir[Length(StartDir)] <> '\' then StartDir := StartDir + '\';
if FindFirst(StartDir + Mask, faAnyFile, SearchRec) = 0 then
begin
repeat Application.ProcessMessages;
if (SearchRec.Attr and faDirectory) <> faDirectory
then
List.Add(StartDir + SearchRec.Name)
else
if (SearchRec.Name <> '..') and (SearchRec.Name <> '.')then
begin
List.Add(StartDir + SearchRec.Name + '\');
ScanDir(StartDir + SearchRec.Name + '\', Mask, List);
end;
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
end;
close;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
RzButton1Click(Sender);
Timer1.Enabled:=false;
end;

procedure TForm1.ZipForge1OverallProgress(Sender: TObject; Progress: Double;
Operation: TZFProcessOperation; ProgressPhase: TZFProgressPhase;
var Cancel: Boolean);
begin

RzProgressBar1.Percent:=Trunc(Progress);
//Application.ProcessMessages;
end;

end.

[Dmitry36]

всем спасибо за "советы", тема закрыта.