Исходный текст программы

unit u1;

 

interface

 

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, VCLZip, VCLUnZip, ComCtrls, ShellCtrls, FileCtrl, Registry, StrUtils,

ExtCtrls, XPMan;

 

type

TForm1 = class(TForm)

GroupBox1: TGroupBox;

OpenDialog1: TOpenDialog;

BnPack: TButton;

Label1: TLabel;

CBRemSrc: TCheckBox;

GroupBox2: TGroupBox;

TrackBar1: TTrackBar;

Label2: TLabel;

Label3: TLabel;

Label4: TLabel;

GroupBox3: TGroupBox;

CBComm: TCheckBox;

BnUnPack: TButton;

SaveDialog1: TSaveDialog;

Edit1: TEdit;

BnUp: TButton;

Panel1: TPanel;

XPManifest1: TXPManifest;

procedure BnPackClick(Sender: TObject);

procedure CBCommClick(Sender: TObject);

procedure BnUnPackClick(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure BnUpClick(Sender: TObject);

procedure Panel1Click(Sender: TObject);

procedure Label2Click(Sender: TObject);

procedure GroupBox2Click(Sender: TObject);

private

procedure CompressFile;

procedure UnZipFile;

procedure SaveSettings;

procedure LoadSettings;

public

end;

 

var

Form1: TForm1; //Переменная формы

hmutex: THandle; //Идентификатор мьютекса

flog: Text; //Переменная файла-лога ошибок

implementation

 

{$R *.DFM}

 

//Процедура записи ошибок в лог и вывода сообщений о них

 

procedure Error(e: string); //Текст сообщения передаём через параметр

begin

try // Начало блока с обрабатываемыми исключениями

//Связываем переменную с файлом, который должен находиться в той же директории

AssignFile(flog,ExtractFilePath(Application.ExeName)+'\errors.log');

//Проверяем, существует ли файл, если да - дополняем, если нет - создаём

if FileExists(ExtractFilePath(Application.ExeName)+'\errors.log') then

Append(flog) else Rewrite(flog);

//Запись в файл строки с датой-временем и сообщением

WriteLn(flog,DateTimeToStr(Date+Time)+' '+e);

//Закрываем файл

CloseFile(flog);

except //Если в файл записать не удалось, игнорируем это

end;

//Вывод сообщения об ошибке

MessageBox(Application.Handle,PChar(e),'Ошибка',MB_ICONERROR);

end;

 

//Процедура распаковки архива, если он передан в качестве параметра

//командной строки

 

procedure UnZipFileCmd;

var

UZip:TVCLUnZip; //Переменная класса для работы с архивами

begin

if not FileExists(ParamStr(1)) then //Если файл не существует,

begin //посылаем ошибку в процедуру

Error(ParamStr(1)+' - указанный файл не найден!');

halt; //Завершаем работу приложения

end;

try //Начало блока с обрабатываемыми исключениями

UZip:= TVCLUnZip.Create (nil); //Создаём объект распаковщика

try //Начало вложенного блока с обработкой исключений

with UZip do //Работаем с объектом

begin

ZipName:=ParamStr(1); //В поле имени архива пишем переданный параметр

ReadZip; //Читаем файл архива

DestDir:=ExtractFilePath(ParamStr(1)); //Извлекаем в ту же папку

FilesList.Add('*'); //Список извлекаемых файлов - все

UnZip; //Распаковка

end;

finally //Даже если и были ошибки,

UZip.Free;//освобождаем ресурсы, занятые объектом

halt; //Завершаем работу приложения

end;

except //Блок обработки исключений (в данном случае при работе с файлами)

on E: EFCreateError do Error(E.Message); //Передаём ошибки в процедуру лога

on E: EFOpenError do Error(E.Message);

on E: EReadError do Error(E.Message);

on E: EWriteError do Error(E.Message);

end;

end;

 

//Процедура сохранения настроек в реестре

 

procedure TForm1.SaveSettings;

var r: TRegistry; //Переменная класса реестра

begin

r:= TRegistry.Create; //Создаём объект реестра

r.OpenKey('Software\ZIPArchiver',true); //Открываем ключ, если нету - создаём

r.WriteInteger('Level',TrackBar1.Position); //Сохраняем степень сжатия

r.WriteString('SavePath',ExtractFilePath(SaveDialog1.FileName)); //и пути,

//по которым открывали и сохраняли архивы

r.WriteString('OpenPath',ExtractFilePath(OpenDialog1.FileName));

r.Free; //Овобождаем ресурсы, занятые объектом

end;

 

//Процедура загрузки настроек из реестра

 

procedure TForm1.LoadSettings;

var r: TRegistry; //Переменная класса реестра

begin

r:= TRegistry.Create; //Создаём объект реестра

if r.OpenKey('Software\ZIPArchiver',false) then //Открываем ключ

begin //Если он есть, читаем

TrackBar1.Position:= r.ReadInteger('Level'); //настройки

OpenDialog1.InitialDir:= r.ReadString('OpenPath');

SaveDialog1.InitialDir:= r.ReadString('SavePath');

end;

r.Free; //Овобождаем ресурсы, занятые объектом

end;

 

procedure TForm1.UnZipFile;

var

UZip:TVCLUnZip; //Переменная класса для работы с архивами

dst:string; //Переменная для пути назначения распакованных файлов

begin

try //Начало блока с обрабатываемыми исключениями

if not OpenDialog1.Execute then exit; //Если в диалоге файл не выбран, выходим

UZip:= TVCLUnZip.Create (nil); //Создаём объект распаковщика

try //Начало вложенного блока с обрабатываемыми исключениями

with UZip do //Работаем с объектом

begin

ZipName:=OpenDialog1.FileName; //Имя архива из диалога

ReadZip; //Считываем архив

if not SelectDirectory('Выбор папки для распакованных файлов','',dst) then

exit; //Если папка назначения не выбрана - выходим

DestDir:=dst; //Путь назначения из диалогового окна

FilesList.Add('*'); //Список извлекаемых файлов - все

GroupBox1.Hide; Panel1.Show; //Вывод таблички "Подождите..."

Form1.Cursor:= crHourGlass; //Курсор-часы

UnZip; //Распаковка

end;

finally //Даже если и были ошибки,

UZip.Free; //освобождаем ресурсы

Panel1.Hide; GroupBox1.Show; //Скрытие таблички "Подождите..."

Form1.Cursor:= crDefault; //Обычный курсор

end;

except //Блок обработки исключений (в данном случае при работе с файлами)

on E: EFCreateError do Error(E.Message); //Передаём ошибки в процедуру лога

on E: EFOpenError do Error(E.Message);

on E: EReadError do Error(E.Message);

on E: EWriteError do Error(E.Message);

end;

end;

 

//Процедура создания архива

 

procedure TForm1.CompressFile;

var

Zip:TVCLZip; //Объявляем переменную класса для работы с архивами

i:integer; //Счётчик

msg:string; //Строка для помещения текста сообщения о размере архива

begin

try //Начало блока с обрабатываемыми исключениями

if not SaveDialog1.Execute then exit; //Если в диалоге файл не указан, выходим

Zip:= TVCLZip.Create (nil); //Создаём объект для работы с архивами

with Zip do //Работаем с объектом

begin

ZipName:= SaveDialog1.FileName; //Имя файла архива берём из диалога

if not (UpperCase(RightStr(SaveDialog1.FileName,4))='.ZIP') then

ZipName:= ZipName + '.zip'; //Если нет расширения - добавляем

for i:= 0 to ShellListView1.Items.Count-1 do //Заполняем список на сжатие из

if (ShellListView1.Items[i].Selected) and //выделенных файлов,

(not ShellListView1.Folders[i].IsFolder) then //папки игнорируем

FilesList.Add(ShellListView1.Folders[i].PathName);

PackLevel:= TrackBar1.Position; //Степень сжатия берём из ползунка

GroupBox1.Hide; Panel1.Show; //Вывод таблички "Подождите..."

Form1.Cursor:= crHourGlass; //Курсор-часы

end;

try //Начало вложенного блока с обрабатываемыми исключениями

Zip.Zip; //Сжимаем

if CBRemSrc.Checked then //Если стоит флажок на удаление исходных файлов,

for i:= 0 to Zip.FilesList.Count-1 do //берём очередной путь из списка

DeleteFile(Zip.FilesList[i]); //и вызываем функцию удаления

if CBComm.Checked then //Если стоит флажок добавления комментария,

begin Zip.ZipComment:= Edit1.Text; //берём его текст из формы

Zip.SaveModifiedZipFile; end; //и сохраняем изменения в архив

msg:= 'Размер полученного архива: '+IntToStr(Zip.ZipSize div 1024)+' Кбайт.';

MessageBox(Form1.Handle,PChar(msg),'Готово',64); //Сообщение о размере архива

finally //Даже если и были ошибки,

Zip.Free; //освобождаем ресурсы

ShellListView1.Refresh; //Обновляем список файлов открытого каталога

Panel1.Hide; GroupBox1.Show; //Скрытие таблички "Подождите..."

Form1.Cursor:= crDefault; //Обычный курсор

end;

except //Блок обработки исключений (в данном случае при работе с файлами)

on E: EFCreateError do Error(E.Message); //Передаём ошибки в процедуру лога

on E: EFOpenError do Error(E.Message);

on E: EReadError do Error(E.Message);

on E: EWriteError do Error(E.Message);

end;

end;

 

//Процедура обработки клика по кнопке "Архивировать..."

 

procedure TForm1.BnPackClick(Sender: TObject);

begin

if ShellListView1.SelCount>0 then CompressFile; //Если есть выделенные

//элементы, вызываем процедуру упаковки

end;

 

//Процедура обработки клика по флажку комментария

 

procedure TForm1.CBCommClick(Sender: TObject);

begin

Edit1.Enabled:=CBComm.Checked; //Поле ввода активно при включенном флажке

if Edit1.Enabled then Edit1.SetFocus; //Если активно, фокусируем для ввода

end;

 

//Процедура обработки клика по кнопке "Распаковать архив..."

 

procedure TForm1.BnUnPackClick(Sender: TObject);

begin

UnZipFile; //Запускаем процедуру, реализующую распаковку

end;

 

//Процедура, выполняемая при создании формы

 

procedure TForm1.FormCreate(Sender: TObject);

begin

LoadSettings; //Вызываем процедуру загрузки настроек из реестра

end;

 

//Процедура, выполняемая при закрытии формы

 

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);

begin

SaveSettings; //Вызываем процедуру сохранения настроек в реестр

end;

 

procedure TForm1.BnUpClick(Sender: TObject);

begin

ShellListView1.Back; //Кнопка "вверх"

end;

 

//Действия при запуске (инициализации) приложения

initialization

if ParamStr(1)<>'' then UnZipFileCmd; //Если передан параметр, вызываем распаковку

 

hmutex:= CreateMutex(nil, false, 'xWgZlf3jt6gR9kO0'); //Создаём мьютекс

if (hmutex = 0) or (GetLastError = ERROR_ALREADY_EXISTS) then //Если не получилось

begin //или уже существует,

Error('Приложение уже запущено!'); //посылаем ошибку в процедуру

halt; //Завершаем работу приложения

end;

 

finalization

if hmutex <> 0 then CloseHandle(hmutex); //При завершении работы закрываем мьютекс

end.