Форум программистов [Powered by Invision Power Board]

Цитата(Marlin @ 22.2.2006, 08:24

)

FlexCompress

Цитата(Marlin @ 22.2.2006, 06:19

)

Во первых я извеняюсь за то, что опублековал этот вопрос в разделе сети, но по непонятным причинам я не могу попасть в раздел "Общие вопросы" мне предлагается скачатьего, а в разделе API при создание новой темы мне вежливо отвечают, что у вас нет прав. Может администратор посмотрит, что там да как.

Цитата(Marlin @ 22.2.2006, 09:24

)

Один файл то можно, а вот каталог целый

Код

unit vgzipper;

interface

uses SysUtils, Classes, ZLib;

const
  ERR_OK         = 0;
  ERR_FILES      = 1;
  ERR_NO_FILES   = 2;
  ERR_CREATE_ARC = 3;
  ERR_NO_ARCHIVE = 4;
  ERR_BAD_ARCHIVE= 5;
  ERR_BAD_DATA   = 6;

function PackDir(ArcName, Path: string; OnWork: TNotifyEvent = nil): byte;
{* запаковать каталог со всеми подкаталогами.
   На входе имя создаваемого архива и путь к каталогу.
   OnWork - необязателен. Выполняется в процессе запаковки. }
function UnPackDir(ArcName, Path: string; OnWork: TNotifyEvent = nil): byte;
{* Распаковать каталог.
   На входе ипя архива и путь к каталогу, куда распаковать файлы.
   OnWork - необязателен. Выполняется в процессе распаковки. }
function ArcErrorText(code: byte): string;
{* Возвращает текст ошибки }

implementation

const signature = 'VGZ'; // сигнатура. Типа VingradGZip.

function ArcErrorText(code: byte): string;
begin
  case code of
    ERR_OK:          result := 'Готово';
    ERR_FILES:       result := 'Не все файлы запакованы';
    ERR_NO_FILES:    result := 'Нет файлов для запаковки';
    ERR_CREATE_ARC:  result := 'Ошибка создания файла архива';
    ERR_NO_ARCHIVE:  result := 'Архив не найден или недоступен';
    ERR_BAD_ARCHIVE: result := 'Файл не является архивом';
    ERR_BAD_DATA:    result := 'Архив поврежден';
    else result := '';
  end;
end;

function PackDir(ArcName, Path: string; OnWork: TNotifyEvent = nil): byte;
var
  fs: TFileStream;
  cs: TCompressionStream;

function FilesScan(Dir: string): byte;
var
  sr: TSearchRec;
  s:  string;
  ln: byte;
  sz: int64;
  fs: TFileStream;
begin
  result := ERR_OK;
  if FindFirst(Dir + '*.*', faAnyFile, sr) = 0 then
  begin
    repeat
      if sr.Name[1] <> '.' then begin
        if sr.Attr and faDirectory = faDirectory then
        begin
          ln := FilesScan(Dir + sr.Name + '\');
          if result = ERR_OK then result := ln;
        end else
        if (sr.Attr and faArchive) = faArchive then
        begin
          s := Dir + sr.Name;
          try
            fs := TFileStream.Create(s, fmOpenRead or fmShareDenyWrite);
            s := copy(s, Length(path)+1, Length(s));
            ln := Length(s);
            cs.Write(ln, 1);
            cs.Write(s[1], ln);
            sz := fs.Size;
            cs.Write(sz, SizeOf(sz));
            cs.CopyFrom(fs, sz);
            fs.Free;
          except
            result := ERR_FILES;
          end;
        end;
      end;
      until FindNext(sr) <> 0;
    FindClose(sr);
  end else result := ERR_NO_FILES;
end;

begin
  if Path[Length(Path)] <> '\' then Path := Path + '\';
  try
    fs := TFileStream.Create(ArcName, fmCreate or fmShareDenyWrite);
    fs.Write(signature[1], Length(signature));
  except
    result := ERR_CREATE_ARC;
    Exit;
  end;
  cs := TCompressionStream.Create(clMax, fs);
  if Assigned(OnWork) then cs.OnProgress := OnWork;
  result := FilesScan(Path);
  cs.Free; fs.Free;
end;


function UnPackDir(ArcName, Path: string; OnWork: TNotifyEvent = nil): byte;
var
  fs,ts: TFileStream;
  ds:    TDecompressionStream;
  s:     string;
  ln:    byte;
  sz:    int64;
begin
  if Path[Length(Path)]<>'\' then Path := Path + '\';
  result := ERR_OK;
  try
    fs := TFileStream.Create(ArcName, fmOpenRead or fmShareDenyWrite);
  except
    result := ERR_NO_ARCHIVE;
    Exit;
  end;
  SetLength(s, Length(signature));
  fs.Read(s[1], Length(signature));
  ds := TDecompressionStream.Create(fs);
  if Assigned(OnWork) then ds.OnProgress := OnWork;
  if s <> signature then result := ERR_BAD_ARCHIVE
  else while (fs.Position<fs.Size) and (result=ERR_OK) do
  begin
    ds.Read(ln, SizeOf(ln));
    SetLength(s, ln);
    ds.Read(s[1], ln);
    s := Path + s;
    try
      ForceDirectories(ExtractFilePath(s));
      ts := TFileStream.Create(s, fmCreate or fmShareDenyWrite);
      ds.Read(sz, SizeOf(sz));
      ts.CopyFrom(ds, sz);
      ts.Free;
    except
      result := ERR_BAD_DATA;
    end;
  end;
  fs.Free;
end;

end.

Код


procedure TForm1.Button1Click(Sender: TObject);
var
  code: byte;
begin
  code := PackDir('C:\arc.vgz', 'C:\Temp\MyDir');
  ShowMessage(ArcErrorText(code));
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  code: byte;
begin
  code := UnPackDir('C:\arc.vgz', 'C:\Temp\Unpack');
  ShowMessage(ArcErrorText(code));
end;

Цитата(Marlin @ 22.2.2006, 11:41

)

Кстати ты сколько уже в делфи и вообще в программировании

Цитата(Marlin @ 22.2.2006, 14:07

)

Snowy ну ты ас. Я еще в дет сад ходил, когда ты в делфи начал разбирать

Цитата(Marlin @ 22.2.2006, 14:07

)

Ребята спасибо вам огромное!

Код

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, vgzipper, ComCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Animate1: TAnimate;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    procedure OnArcWork(Sender: TObject);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.OnArcWork(Sender: TObject);
begin
  Application.ProcessMessages;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  code: byte;
begin
  Button1.Enabled := false; Button2.Enabled := false;
  Animate1.CommonAVI := aviCopyFiles;
  Animate1.Visible := true;  Animate1.Play(1, 0, 0);
  code := PackDir('C:\arc.vgz', 'C:\bin', OnArcWork);
  Animate1.Stop;
  ShowMessage(ArcErrorText(code));
  Animate1.Visible := false;
  Button1.Enabled := true; Button2.Enabled := true;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  code: byte;
begin
  Button1.Enabled := false; Button2.Enabled := false;
  Animate1.CommonAVI := aviCopyFiles;
  Animate1.Visible := true;  Animate1.Play(1, 0, 0);
  code := UnPackDir('C:\arc.vgz', 'C:\Temp\Unpack', OnArcWork);
  Animate1.Stop;
  ShowMessage(ArcErrorText(code));
  Animate1.Visible := false;
  Button1.Enabled := true; Button2.Enabled := true;
end;

end.

Цитата(vood @ 25.2.2006, 10:24

)

А мне кажеться Zlib лучше