熱點推薦:
您现在的位置: 電腦知識網 >> 編程 >> Delphi編程 >> 正文

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

2013-11-11 21:04:12  來源: Delphi編程 

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

  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
    Copyright © 2005-2013 電腦知識網 Computer Knowledge   All rights reserved.