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.
