復雜的結構化存取(三):存取函數

　　今天寫了四個小函數 拿來與大家共享

　　DirDoc 把文件夾下的所有文件（不包括子文件夾）保存成一個復合文件

　　DocDir DirDoc 的反操作

　　ZipDirDoc 同 DirDoc 只是同時執行了壓縮

　　UnZipDocDir ZipDirDoc 的反操作

　　函數及測試代碼（分別在 Delphi 和 Delphi 下測試通過）

unit　Unit;

　　interface

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

　　type
　TForm　=　class(TForm)
　　Button:　TButton;
　　Button:　TButton;
　　Button:　TButton;
　　Button:　TButton;
　　procedure　ButtonClick(Sender:　TObject);
　　procedure　ButtonClick(Sender:　TObject);
　　procedure　ButtonClick(Sender:　TObject);
　　procedure　ButtonClick(Sender:　TObject);
　end;

　　var
　Form:　TForm;

　　implementation

　　{$R　*dfm}

　　uses　ActiveX　Zlib;　{函數用到的單元}

　　{把指定文件夾下的文件保存到一個復合文件}
function　DirDoc(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　　Stg);　{建立復合文件根路徑}

　　if　FindFirst(SourcePath　+　**　faAnyFile　sr)　=　　then
　begin
　　repeat
　　　if　srName[]　=　　then　Continue;　{如果是　或　　(當前目錄或上層目錄)則忽略}
　　　if　(srAttr　and　faDirectory)　<>　faDirectory　then
　　　begin
　　　　StgCreateStream(PWideChar(WideString(srName))　Mode　　　Stm);
　　　　ms　:=　TMemoryStreamCreate;
　　　　msLoadFromFile(SourcePath　+　　+　srName);
　　　　msPosition　:=　;
　　　　StmWrite(msMemory　msSize　nil);
　　　　msFree;
　　　end;
　　until　(FindNext(sr)　<>　);
　end;
　Result　:=　True;
end;

　　{上一個　DirDoc　函數的反操作}
function　DocDir(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　　Stg);
　StgEnumElements(　nil　　EnumStatStg);

　　while　True　do
　begin
　　EnumStatStgNext(　StatStg　@i);
　　if　(i　=　)　or　(StatStgdwType　=　)　then　Break;　{dwType　=　　時是文件夾}
　　StgOpenStream(StatStgpwcsName　nil　Mode　　Stm);
　　ms　:=　TMemoryStreamCreate;
　　msSetSize(StatStgcbSize);
　　StmRead(msMemory　msSize　nil);
　　msSaveToFile(DestPath　+　　+　StatStgpwcsName);
　　msFree;
　end;
　Result　:=　True;
end;

　　{把指定文件夾下的文件壓縮到一個復合文件}
function　ZipDirDoc(SourcePath　DestFile:　string):　Boolean;
const
　Mode　=　STGM_CREATE　or　STGM_WRITE　or　STGM_SHARE_EXCLUSIVE;
var
　sr:　TSearchRec;
　Stg:　IStorage;
　Stm:　IStream;
　msms:　TMemoryStream;
　zip:　TCompressionStream;
　num:　Int;
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　　Stg);　{建立復合文件根路徑}

　　if　FindFirst(SourcePath　+　**　faAnyFile　sr)　=　　then
　begin
　　repeat
　　　if　srName[]　=　　then　Continue;　{如果是　或　　(當前目錄或上層目錄)則忽略}
　　　if　(srAttr　and　faDirectory)　<>　faDirectory　then
　　　begin
　　　　StgCreateStream(PWideChar(WideString(srName))　Mode　　　Stm);
　　　　ms　:=　TMemoryStreamCreate;
　　　　ms　:=　TMemoryStreamCreate;
　　　　msLoadFromFile(SourcePath　+　　+　srName);

　　num　:=　msSize;
　　　　msWrite(num　SizeOf(num));
　　　　zip　:=　TCompressionStreamCreate(clMax　ms);
　　　　msSaveToStream(zip);
　　　　zipFree;

　　msPosition　:=　;
　　　　StmWrite(msMemory　msSize　nil);

　　msFree;
　　　　msFree;
　　　end;
　　until　(FindNext(sr)　<>　);
　end;
　Result　:=　True;
end;

　　{上一個　ZipDirDoc　函數的反操作}
function　UnZipDocDir(SourceFile　DestPath:　string):　Boolean;
const
　Mode　=　STGM_READ　or　STGM_SHARE_EXCLUSIVE;
var
　Stg:　IStorage;
　Stm:　IStream;
　StatStg:　TStatStg;
　EnumStatStg:　IEnumStatStg;
　msms:　TMemoryStream;
　i:　Integer;
　num:　Int;
　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　　Stg);
　StgEnumElements(　nil　　EnumStatStg);

　　while　True　do
　begin
　　EnumStatStgNext(　StatStg　@i);
　　if　(i　=　)　or　(StatStgdwType　=　)　then　Break;　{dwType　=　　時是文件夾}
　　StgOpenStream(StatStgpwcsName　nil　Mode　　Stm);
　　ms　:=　TMemoryStreamCreate;
　　msSetSize(StatStgcbSize);
　　StmRead(msMemory　msSize　nil);
　　msPosition　:=　;
　　msReadBuffer(num　SizeOf(num));
　　ms　:=　TMemoryStreamCreate;
　　msSetSize(num);

　　UnZip　:=　TDecompressionStreamCreate(ms);
　　msPosition　:=　;
　　UnZipRead(msMemory^　num);
　　UnZipFree;

　　msSaveToFile(DestPath　+　　+　StatStgpwcsName);
　　msFree;
　　msFree;
　end;
　Result　:=　True;
end;

　　{測試　DirDoc}
procedure　TFormButtonClick(Sender:　TObject);
const
　TestPath　=　C:Documents　and　SettingsAll　UsersDocumentsMy　Pictures示例圖片;
　TestFile　=　C:Temppicdat;
begin
　if　DirDoc(TestPath　TestFile)　then
　　ShowMessage(ok);
end;

　　{測試　DocDir}
procedure　TFormButtonClick(Sender:　TObject);
const
　TestPath　=　C:Temppic;
　TestFile　=　C:Temppicdat;
begin
　if　DocDir(TestFile　TestPath)　then
　　ShowMessage(ok);
end;

　　{測試　ZipDirDoc}
procedure　TFormButtonClick(Sender:　TObject);
const
　TestPath　=　C:Documents　and　SettingsAll　UsersDocumentsMy　Pictures示例圖片;
　TestFile　=　C:Temppicdat;
begin
　if　ZipDirDoc(TestPath　TestFile)　then
　　ShowMessage(ok);
end;

　　{測試　UnZipDocDir}
procedure　TFormButtonClick(Sender:　TObject);
const
　TestPath　=　C:Temppic;
　TestFile　=　C:Temppicdat;
begin
　if　UnZipDocDir(TestFile　TestPath)　then
　　ShowMessage(ok);
end;

From:http://tw.wingwit.com/Article/program/Delphi/201311/8403.html