今天寫了四個小函數, 拿來與大家共享:
Dir2Doc: 把文件夾下的所有文件(不包括子文件夾)保存成一個復合文件;
Doc2Dir: Dir2Doc 的反操作;
ZipDir2Doc: 同 Dir2Doc, 只是同時執行了壓縮;
UnZipDoc2Dir: ZipDir2Doc 的反操作.
函數及測試代碼(分別在 Delphi 2007 和 Delphi 2009 下測試通過):
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses ActiveX, Zlib; {函數用到的單元}
{把指定文件夾下的文件保存到一個復合文件}
function Dir2Doc(SourcePath, DestFile: string): Boolean;
const
Mode = STGM_CREATE or STGM_WRITE or STGM_SHARE_EXCLUSIVE;
var
sr: TSearchRec;
Stg: IStorage;
Stm: IStream;
ms: TMemoryStream;
begin
Result := False;
SourcePath := ExcludeTrailingPathDelimiter(SourcePath); {去掉最後一個 ''}
if not DirectoryExists(SourcePath) then Exit; {如果源路徑不存在則退出}
if not DirectoryExists(ExtractFileDir(DestFile)) then {假如目標目錄不存在}
if not ForceDirectorIEs(ExtractFileDir(DestFile)) then Exit; {就創建, 若創建失敗退出.}
{如果目標路徑不存在則退出}
StgCreateDocfile(PWideChar(WideString(DestFile)), Mode, 0, Stg); {建立復合文件根路徑}
if FindFirst(SourcePath + '*.*', faAnyFile, sr) = 0 then
begin
repeat
if sr.Name[1] = '.' then Continue; {如果是'.' 或 '..' (當前目錄或上層目錄)則忽略}
if (sr.Attr and faDirectory) <> faDirectory then
begin
Stg.CreateStream(PWideChar(WideString(sr.Name)), Mode, 0, 0, Stm);
ms := TMemoryStream.Create;
ms.LoadFromFile(SourcePath + '' + sr.Name);
ms.Position := 0;
Stm.Write(ms.Memory, ms.Size, nil);
ms.Free;
end;
until (FindNext(sr) <> 0);
end;
Result := True;
end;
{上一個 Dir2Doc 函數的反操作}
function Doc2Dir(SourceFile, DestPath: string): Boolean;
const
Mode = STGM_READ or STGM_SHARE_EXCLUSIVE;
var
Stg: IStorage;
Stm: IStream;
StatStg: TStatStg;
EnumStatStg: IEnumStatStg;
ms: TMemoryStream;
i: Integer;
begin
Result := False;
if not FileExists(SourceFile) then Exit; {如果文件不存在退出}
if not DirectoryExists(DestPath) then {如果目標目錄不存在}
if not ForceDirectorIEs(DestPath) then Exit; {就創建, 若創建失敗退出}
DestPath := ExcludeTrailingPathDelimiter(DestPath); {去掉最後一個 ''}
StgOpenStorage(PWideChar(WideString(SourceFile)), nil, Mode, nil, 0, Stg);
Stg.EnumElements(0, nil, 0, EnumStatStg);
while True do
begin
EnumStatStg.Next(1, StatStg, @i);
if (i = 0) or (StatStg.dwType = 1) then Break; {dwType = 1 時是文件夾}
Stg.OpenStream(StatStg.pwcsName, nil, Mode, 0, Stm);
ms := TMemoryStream.Create;
ms.SetSize(StatStg.cbSize);
Stm.Read(ms.Memory, ms.Size, nil);
ms.SaveToFile(DestPath + '' + StatStg.pwcsName);
ms.Free;
end;
Result := True;
end;
{把指定文件夾下的文件壓縮到一個復合文件}
function ZipDir2Doc(SourcePath, DestFile: string): Boolean;
const
Mode = STGM_CREATE or STGM_WRITE or STGM_SHARE_EXCLUSIVE;
var
sr: TSearchRec;
Stg: IStorage;
Stm: IStream;
ms1,ms2: TMemoryStream;
zip: TCompressionStream;
num: Int64;
begin
Result := False;
SourcePath := ExcludeTrailingPathDelimiter(SourcePath); {去掉最後一個 ''}
if not DirectoryExists(SourcePath) then Exit; {如果源路徑不存在則退出}
if not DirectoryExists(ExtractFileDir(DestFile)) then {假如目標目錄不存在}
if not ForceDirectorIEs(ExtractFileDir(DestFile)) then Exit; {就創建, 若創建失敗退出.}
StgCreateDocfile(PWideChar(WideString(DestFile)), Mode, 0, Stg); {建立復合文件根路徑}
if FindFirst(SourcePath + '*.*', faAnyFile, sr) = 0 then
begin
repeat
if sr.Name[1] = '.' then Continue; {如果是'.' 或 '..' (當前目錄或上層目錄)則忽略}
if (sr.Attr and faDirectory) <> faDirectory then
begin
Stg.CreateStream(PWideChar(WideString(sr.Name)), Mode, 0, 0, Stm);
ms1 := TMemoryStream.Create;
ms2 := TMemoryStream.Create;
ms1.LoadFromFile(SourcePath + '' + sr.Name);
num := ms1.Size;
ms2.Write(num, SizeOf(num));
zip := TCompressionStream.Create(clMax, ms2);
ms1.SaveToStream(zip);
zip.Free;
ms2.Position := 0;
Stm.Write(ms2.Memory, ms2.Size, nil);
ms1.Free;
ms2.Free;
end;
until (FindNext(sr) <> 0);
end;
Result := True;
end;
{上一個 ZipDir2Doc 函數的反操作}
function UnZipDoc2Dir(SourceFile, DestPath: string): Boolean;
const
Mode = STGM_READ or STGM_SHARE_EXCLUSIVE;
var
Stg: IStorage;
Stm: IStream;
StatStg: TStatStg;
EnumStatStg: IEnumStatStg;
ms1,ms2: TMemoryStream;
i: Integer;
num: Int64;
UnZip: TDecompressionStream;
begin
Result := False;
if not FileExists(SourceFile) then Exit; {如果文件不存在退出}
if not DirectoryExists(DestPath) then {如果目標目錄不存在}
if not ForceDirectorIEs(DestPath) then Exit; {就創建, 若創建失敗退出}
DestPath := ExcludeTrailingPathDelimiter(DestPath); {去掉最後一個 ''}
StgOpenStorage(PWideChar(WideString(SourceFile)), nil, Mode, nil, 0, Stg);
Stg.EnumElements(0, nil, 0, EnumStatStg);
while True do
begin
EnumStatStg.Next(1, StatStg, @i);
if (i = 0) or (StatStg.dwType = 1) then Break; {dwType = 1 時是文件夾}
Stg.OpenStream(StatStg.pwcsName, nil, Mode, 0, Stm);
ms1 := TMemoryStream.Create;
ms1.SetSize(StatStg.cbSize);
Stm.Read(ms1.Memory, ms1.Size, nil);
ms1.Position := 0;
ms1.ReadBuffer(num, SizeOf(num));
ms2 := TMemoryStream.Create;
ms2.SetSize(num);
UnZip := TDecompressionStream.Create(ms1);
ms2.Position := 0;
UnZip.Read(ms2.Memory^, num);
UnZip.Free;
ms2.SaveToFile(DestPath + '' + StatStg.pwcsName);
ms1.Free;
ms2.Free;
end;
Result := True;
end;
{測試 Dir2Doc}
procedure TForm1.Button1Click(Sender: TObject);
const
TestPath = 'C:Documents and SettingsAll UsersDocumentsMy Pictures示例圖片';
TestFile = 'C:Temppic1.dat';
begin
if Dir2Doc(TestPath, TestFile) then
ShowMessage('ok');
end;
{測試 Doc2Dir}
procedure TForm1.Button2Click(Sender: TObject);
const
TestPath = 'C:Temppic1';
TestFile = 'C:Temppic1.dat';
begin
if Doc2Dir(TestFile, TestPath) then
ShowMessage('ok');
end;
{測試 ZipDir2Doc}
procedure TForm1.Button3Click(Sender: TObject);
const
TestPath = 'C:Documents and SettingsAll UsersDocumentsMy Pictures示例圖片';
TestFile = 'C:Temppic2.dat';
begin
if ZipDir2Doc(TestPath, TestFile) then
ShowMessage('ok');
end;
{測試 UnZipDoc2Dir}
procedure TForm1.Button4Click(Sender: TObject);
const
TestPath = 'C:Temppic2';
TestFile = 'C:Temppic2.dat';
begin
if UnZipDoc2Dir(TestFile, TestPath) then
ShowMessage('ok');
end;
end.
