|
|
Регистрация | << Правила форума >> | FAQ | Пользователи | Календарь | Поиск | Сообщения за сегодня | Все разделы прочитаны |
|
Опции темы | Поиск в этой теме | Опции просмотра |
#1
|
|||
|
|||
недопонимание zipforge ((
Добрый день, уважаемые форумчане!!
стояла следующая задача: архивировать дифференциальные Бэкапы БД, каждые 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, 05.07.2013 в 15:01. |