Lazarus 文件压缩 与 字符下缩

unit zip_main;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  Buttons, zstream, Zipper,Base64;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    SelectDirectoryDialog1: TSelectDirectoryDialog;
    unZipBtn: TBitBtn;
    localDirLbl: TLabel;
    OpenDialog1: TOpenDialog;
    zipFileBtn: TBitBtn;
    pathEdit: TEdit;
    zipDirBtn: TBitBtn;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure unZipBtnClick(Sender: TObject);
    procedure zipDirBtnClick(Sender: TObject);
    procedure zipFileBtnClick(Sender: TObject);
  private
    { private declarations }
    function GzBase64(const s: string): string;
    function unGzBase64(const s: string): string;
    function   Base64ToString(const   Value:   string):   string;
  public
    { public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

function TForm1.GzBase64(const s: string): string;
var OutStream, InpStream, GzStream, b64Stream: TStream;
begin
   OutStream := TStringStream.Create('');
   try
    b64Stream := TBase64EncodingStream.Create(OutStream);
      try
         GzStream := Tcompressionstream.create(clmax,b64Stream);
         try
            InpStream := TStringStream.Create(s);
            try
               // Copy input stream
               GzStream.CopyFrom(InpStream,InpStream.Size);
            finally
               InpStream.Free;
            end;
         finally
            GzStream.Free;
         end;
      finally
         b64Stream.Free;
      end;
      result := TStringStream(OutStream).DataString;
   finally
      OutStream.Free;
   end;
end;
function TForm1.unGzBase64(const s: string): string;
var OutStream,deCompressStream: TStream;
     SL:TStringList;

begin
  if s='' then
  begin
    Result:='';
    abort;
  end;

 SL := TStringList.Create;
 OutStream := TStringStream.Create(Base64ToString(s));
 DecompressStream := TDecompressionStream.Create(OutStream);

 try
  SL.LoadFromStream(DecompressStream);
  Result:=SL.Text;
  finally
    DecompressStream.Free;
    OutStream.Free;
    SL.Free;
  end;
end;

function   TForm1.Base64ToString(const   Value:   string):   string;
var
    x,   y,   n,   l:   Integer;
    d:   array[0..3]   of   Byte;
    Table   :   string;
begin
    Table   :=
        #$40   +#$40   +#$40   +#$40   +#$40   +#$40   +#$40   +#$40   +#$40   +#$40   +#$3E   +#$40
        +#$40   +#$40   +#$3F   +#$34   +#$35   +#$36   +#$37   +#$38   +#$39   +#$3A   +#$3B   +#$3C
        +#$3D   +#$40   +#$40   +#$40   +#$40   +#$40   +#$40   +#$40   +#$00   +#$01   +#$02   +#$03
        +#$04   +#$05   +#$06   +#$07   +#$08   +#$09   +#$0A   +#$0B   +#$0C   +#$0D   +#$0E   +#$0F
        +#$10   +#$11   +#$12   +#$13   +#$14   +#$15   +#$16   +#$17   +#$18   +#$19   +#$40   +#$40
        +#$40   +#$40   +#$40   +#$40   +#$1A   +#$1B   +#$1C   +#$1D   +#$1E   +#$1F   +#$20   +#$21
        +#$22   +#$23   +#$24   +#$25   +#$26   +#$27   +#$28   +#$29   +#$2A   +#$2B   +#$2C   +#$2D
        +#$2E   +#$2F   +#$30   +#$31   +#$32   +#$33   +#$40   +#$40   +#$40   +#$40   +#$40   +#$40;

    SetLength(Result,   Length(Value));
    x   :=   1;
    l   :=   1;
    while   x   <   Length(Value)   do
    begin
        for   n   :=   0   to   3   do
        begin
            if   x   >   Length(Value)   then
                d[n]   :=   64
            else
            begin
                y   :=   Ord(Value[x]);
                if   (y   <   33)   or   (y   >   127)   then
                    d[n]   :=   64
                else
                    d[n]   :=   Ord(Table[y   -   32]);
            end;
            Inc(x);
        end;
        Result[l]   :=   Char((D[0]   and   $3F)   shl   2   +   (D[1]   and   $30)   shr   4);
        Inc(l);
        if   d[2]   <>   64   then
        begin
            Result[l]   :=   Char((D[1]   and   $0F)   shl   4   +   (D[2]   and   $3C)   shr   2);
            Inc(l);
            if   d[3]   <>   64   then
            begin
                Result[l]   :=   Char((D[2]   and   $03)   shl   6   +   (D[3]   and   $3F));
                Inc(l);
            end;
        end;
    end;
    Dec(l);
    SetLength(Result,   l);
end;

 

 

 

procedure TForm1.zipFileBtnClick(Sender: TObject);
var Zipper: TZipper;
  zfe: TZipFileEntry;
begin
  OpenDialog1.Title := '要压缩的文件';
  Opendialog1.Filter :=  '全部文件(*.*)|*.*';
  if OpenDialog1.Execute then Begin
    try
      Zipper := TZipper.Create;
      Zipper.FileName := OpenDialog1.FileName + '.zip';
      zfe := Zipper.Entries.AddFileEntry(OpenDialog1.FileName, ExtractFileName(OpenDialog1.FileName));
      zfe.CompressionLevel := clfastest;         //压缩率：快速 {clfastest,    cldefault,    clmax}

      Zipper.ZipAllFiles;
    finally
      Zipper.Free;
    end;

    pathEdit.Text := OpenDialog1.FileName + '.zip';
    showmessage('文件压缩成功');
  end;
end;

procedure TForm1.unZipBtnClick(Sender: TObject);
var unzipper : TUnzipper;
    EDir, FileName : string;
begin
  OpenDialog1.Title := '要解压的zip文件';
  Opendialog1.Filter :=  'zip file(*.zip)|*.zip';
  if OpenDialog1.Execute then begin
    if not fileExists(OpenDialog1.FileName) then
      Exit;
    pathEdit.Text := OpenDialog1.FileName;

    EDir := extractFileName(OpenDialog1.FileName) + '.old';
    if not DirectoryExists(edir) then
      CreateDir(edir);
    unzipper := TUnzipper.create;
    unzipper.FileName := OpenDialog1.FileName;
    unzipper.outputpath := EDir;
    unzipper.UnzipAllFiles;
    showmessage('解压成功');
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  SelectDirectoryDialog1.InitialDir := ExtractFilePath(ParamStr(0));
  OpenDialog1.InitialDir := ExtractFilePath(ParamStr(0));
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Zipper: TZipper;
begin
  //Zipper.Entries. ;
end;

procedure TForm1.zipDirBtnClick(Sender: TObject);
var Zipper: TZipper;
  ZEntries: TZipFileEntries;
  sourceRec: TSearchRec;
  i: smallint;
begin
  SelectDirectoryDialog1.Title := '要压缩的目录';
  SelectDirectoryDialog1.Filter :=  '全部目录(*.*)|*.*';
  if SelectDirectoryDialog1.Execute then Begin
    try
      Zipper := TZipper.Create;
      Zipper.FileName := SelectDirectoryDialog1.FileName + '.zip';

      i := findFirst(SelectDirectoryDialog1.FileName + '\*.*', faAnyFile, sourceRec);
      ZEntries := TZipFileEntries.Create(TZipFileEntry);
      while(i = 0) do begin
        if (sourceRec.Attr and faDirectory) = 0 then //不要子目录
          ZEntries.AddFileEntry(SelectDirectoryDialog1.FileName + '\' + sourceRec.Name, sourceRec.Name);
        i := FindNext(sourceRec);
      end;
      FindClose(sourceRec);
      if ZEntries.Count>0 then
        Zipper.ZipFiles(ZEntries);
    finally
      FreeAndNil(ZEntries);
      FreeAndNil(Zipper);
    end;

    pathEdit.Text := SelectDirectoryDialog1.FileName + '.zip';
    showmessage('目录压缩成功');
  end;
end;

end.