vclzip压缩

昵称7887676 2012-10-29

展开全文

 Pascal Code 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127

unit uCompressData;

interface

uses Classes, VCLUnZip, VCLZip, Windows, Forms, SysUtils;

type
  TCompressData=class(Tobject)
  private
    FPassWord: string;
    FVCLZip: TVCLZip;
    FOnFilePercentDone: TFilePercentDone;
    FFileName: string;
    FFileListTxt: string;
    FRootDir: string;
    FOnZipComplete: TZipComplete;
    FOnCompressError: TNotifyEvent;
    procedure SetPassWord(const Value: string);
    procedure SetOnFilePercentDone(const Value: TFilePercentDone);
    procedure SetFileName(const Value: string);
    procedure SetFileListTxt(const Value: string);
    function GetFileListTxt: string;
    procedure SetRootDir(const Value: string);
    procedure SetOnZipComplete(const Value: TZipComplete);
    procedure SetOnCompressError(const Value: TNotifyEvent);
  public
    function Compress:Boolean;
    procedure AddFile(AFile: string);
    constructor Create;
    destructor Destroy; override;
    property PassWord:string read FPassWord write SetPassWord;
    property FileName:string read FFileName write SetFileName;
    property RootDir:string read FRootDir write SetRootDir;
    property FileListTxt:string read GetFileListTxt write SetFileListTxt;
    property OnCompressError:TNotifyEvent read FOnCompressError write SetOnCompressError;
    property OnFilePercentDone: TFilePercentDone read FOnFilePercentDone write SetOnFilePercentDone;
    property OnZipComplete: TZipComplete read FOnZipComplete write SetOnZipComplete;
  end;

implementation

{ TLoadSaveData }

procedure TCompressData.AddFile(AFile: string);
begin
  FVCLZip.FilesList.Add(AFile);
end;

constructor TCompressData.Create;
begin
  FVCLZip:= TVCLZip.Create(Application);
end;

destructor TCompressData.Destroy;
begin
  FVCLZip.Free;
  inherited;
end;

function TCompressData.GetFileListTxt: string;
begin
  Result:= FVCLZip.FilesList.Text;
end;

function TCompressData.Compress:Boolean;
begin
  try
    with FVCLZip do
      begin
        ZipName:= FFileName;
        RecreateDirs:=true;
        StorePaths:=True;
        Password := FPassWord;
        Recurse := True;
        RelativePaths := True;
        RootDir:=FRootDir;
        Zip;
      end;
    Result:=True;
  except
    Result:=False;
    if Assigned(FOnCompressError) then
      FOnCompressError(Self);
    exit;
  end;
end;

procedure TCompressData.SetFileListTxt(const Value: string);
begin
  FFileListTxt := Value;
  FVCLZip.FilesList.Text:= FFileListTxt;
end;

procedure TCompressData.SetFileName(const Value: string);
begin
  FFileName := Value;
end;

procedure TCompressData.SetOnCompressError(const Value: TNotifyEvent);
begin
  FOnCompressError := Value;
end;

procedure TCompressData.SetOnFilePercentDone(const Value: TFilePercentDone);
begin
  FOnFilePercentDone := Value;
  FVCLZip.OnFilePercentDone := FOnFilePercentDone;
end;

procedure TCompressData.SetOnZipComplete(const Value: TZipComplete);
begin
  FOnZipComplete := Value;
  FVCLZip.OnZipComplete:= FOnZipComplete;
end;

procedure TCompressData.SetPassWord(const Value: string);
begin
  FPassWord := Value;
end;

procedure TCompressData.SetRootDir(const Value: string);
begin
  FRootDir := Value;
end;

end.

贴个自己写的共用单元给你，已经测过的

 Pascal Code 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79

unit uVclZipPublic;

interface

uses SysUtils, Variants, Classes,VCLZip,VCLUnZip;

function ZipFiles(zipControl:TVCLZip;Files:TStrings;MyZipName:string):Boolean;
function UnZipFiles(zipControl:TVCLZip;MyZipName,MyDestDir:string):Boolean;
function ZipDir(zipMode{0-连同根目录一起压缩，1-压缩指定目录中的所有文件和文件夹}:Integer;zipControl:TVCLZip;MyZipName,MyZipDir:string):Boolean;

implementation

function ZipFiles(ZipControl:TVCLZip;Files:TStrings;MyZipName:string):Boolean;
begin
  Result:=False;
  try
  with ZipControl do
  begin
  FilesList.Text:=Files.Text;
  ZipName:=MyZipName;
  Zip;
  Result:=True;
  end;
  except
  //Showmessage('');
  end;
end;

function UnZipFiles(zipControl:TVCLZip;MyZipName,MyDestDir:string):Boolean;
begin
  Result:=False;
  try
  with zipControl do
  begin
  ZipName:=MyZipName;
  ReadZip;
  DestDir:=MyDestDir;
  OverwriteMode:=Always;
  RelativePaths:=True;
  RecreateDirs:=True;
  DoAll:=True;

  FilesList.Add('*.*');
  UnZip;
  Result:=True;
  end;
  except

  end;
end;

function ZipDir(zipMode{0-连同目录一起压缩，1-压缩指定目录中的所有文件和文件夹}:Integer;zipControl:TVCLZip;MyZipName,MyZipDir:string):Boolean;
begin
  {压缩指定目录中的所有文件和文件夹，指定RootDir，否则连同指定目录本身一同压缩}
  Result:=False;
  try
  with zipControl do
  begin
  case zipMode of
  0:RootDir:='';
  1:RootDir:=MyZipDir;
  end;
  OverwriteMode:=Always;
  AddDirEntriesOnRecurse:=True;
  RelativePaths:=True;
  //Recurse:=True;
  //RecreateDirs:=True;
  //StorePaths:=True;
  ZipName:=MyZipName;
  FilesList.Add(MyZipDir+'\*.*');
  Zip;
  Result:=True;
  end;
  except

  end;
end;

end.