Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2010年05月16日] [更新 2013年02月13日]　Delphi サンプルプログラム集
   
733_Windows XP 以降の圧縮・展開機能を使う
動作確認等 Windows 7 U64(SP2) + Delphi XE Pro
733__ArchiverWindowsZIP.zip　[1,828 KB]　2013年02月13日版 (EXE 同梱)






Windows XP 以降の圧縮・展開機能を使う


Windows XP 以降には，ZIP ファイルの圧縮・展開の機能が追加されています．
エクスプローラでフォルダを展開して表示するのと同じことを意味しています．もちろん解凍もできます．また，Windows 7 では LZH ファイルの展開だけですが機能が追加されています．

このページのサンプルコードは，これらの機能を使用したテストプログラムです．ただし，他の圧縮・解凍ソフトをインストールしたり，何らかの操作でこの機能を使用できない状態になっている場合は利用できません．この機能が有効になっていれば，ZIP 書庫の場合，あえて解凍しなくても，書庫内を「展開」表示して通常のファイルとしての操作ができます．
この機能が使用できなくなっている場合は，[ZIP ファイルの関連付けの設定を初期化したい] を参考にしてみてください．この時，圧縮・解凍用にインストールしたアプリケーションはアンインストールした方が確実です．また，メーカー製の PC ではツールが用意されている場合があります．

このページのコードは，OK Ware にあった VBScript のコードを参考にしました．





01_タイプライブラリの取り込み


このページのサンプルでは，Shell オブジェクトと FileSystemObject を使用しています．これらを使用するには，Shell32_TLB.pas と Scripting_TLBpas を「タイプライブラリの取り込み」で作成しておきます．
Windows のエクスプローラで ZIP や LZH を展開表示できるということは，それらをフォルダやファイルとして扱っていることですが，Delphi のファイル操作関係の関数ではこの操作はできません．エクスプローラは Windows のシェルが提供している機能です．このシェルオブジェクトを扱う必要があります．Windows API にも関係する関数がありますが，タイプライブラリで取込んでこれらを利用する方が簡単なので使用してみることにしました．


図1
Shell2.TLB.pas の作成
  • [コンポーネント]
    [コンポーネントのインポート]
  • [タイプライブラリの取り込み]
  • [ユニットの作成] を選択して作成

  • 当ページのサンプルでは，パッケージへのインストールは不要
図2
Scripting_TLB.pas の作成
  • [コンポーネント]
    [コンポーネントのインポート]
  • [ユニットの作成]を 選択して作成

  • 当ページのサンプルでは，パッケージへのインストールは不要




02_ZIP 書庫ファイルの圧縮・解凍


ZIP ファイルの圧縮・解凍のサンプルです．
ZIP ファイルをフォルダとして，圧縮の時はそのフォルダにファイルなりフォルダをコピーし，解凍の時は，ファイルやフォルダを他のフォルダにコピーします．
NameSpace メソッドと ParseName メソッドが各々フォルダとファイルのシェルオブジェクトを取得する(返す)メソッドです．


図3
設計時画面
図4
実行結果例
  • テストをいろいろした結果

リスト1
Windows XP 以降の ZIP 圧縮・展開機能を使用して ZIP 書庫を圧縮・解凍 
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls , Shell32_TLB, Scripting_TLB, ExtCtrls;

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private 宣言 }
    procedure CreateNewZIPFile(AFileName: String);
    procedure SHDeleteFileFolder(AFileName: String);
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses FileCtrl;

{$R *.dfm}

//=============================================================================
//  ZIP書庫圧縮
//  選択したファイルを圧縮
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  BasePath     : String;
  DestPath     : String;
  FileList     : TStringList;
  i            : Integer;
  SHShell      : Shell32_TLB.TShell;
  SHBaseFolder : Shell32_TLB.Folder;
  SHDestFolder : Shell32_TLB.Folder;
  SHFolderItem : Shell32_TLB.FolderItem;
begin

  //圧縮対象のファイルを選択(複数選択可能)
  BasePath  := ExtractFilePath(Application.ExeName);

  OpenDialog1.Options    := OpenDialog1.Options + [ofAllowMultiSelect];
  OpenDialog1.InitialDir := BasePath;
  OpenDialog1.Filter     := '';
  OpenDialog1.FileName   := '';

  if OpenDialog1.Execute then begin
    Update;

    //書庫に格納するファイルのリスト用TStringList
    Filelist  :=TStringList.Create;
    //フォルダやファイルをシェルオブジェクトとして扱うためのTShell
    SHShell := TShell.Create(Self);

    try
      //OpenDialgotで選択したファイルをリストに格納
      FileList.AddStrings(OpenDialog1.Files);

      //圧縮後のファイル名(フルパス)
      //このプロジェクトのフォルダ内のTEMPフォルダ内とする
      //このファイルがないと例外発生
      DestPath := BasePath + 'TEMP\TestA.ZIP';
      //この名前でZIP書庫ファイルを新規作成
      CreateNewZIPFile(DestPath);

      try
        //作成する書庫ファイルのシェルオブジェクトを取得(フォルダ扱い)
        SHDestFolder := SHShell.NameSpace(DestPath);

        //格納するファイルの基準ディレクトリのシェルオブジェクト
        SHBaseFolder := SHShell.NameSpace(ExtractFileDir(FileList[0]));
        //各ファイルのシェルオブジェクトを取得して格納していく(コピー)
        for  i := 0 to FileList.Count - 1 do begin
          SHFolderItem := SHBaseFolder.ParseName(ExtractFileName(FileList[i]));
          SHDestFolder.CopyHere(SHFolderItem, 0);
        end;
      except
        ShowMessage('このシステムでは，この機能は使用できません．　');
        //失敗したので作成したファイルは削除しておく
        SHDeleteFileFolder(DestPath);
      end;
    finally
      FreeAndNil(FileList);
      FreeAndNil(SHShell);
    end;
  end;
end;

//=============================================================================
//  ZIP書庫圧縮
//  選択フォルダ(ディレクトリ)下を圧縮
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  DestPath     : String;
  SHShell      : Shell32_TLB.TShell;
  SHSrcFolder  : Shell32_TLB.Folder;
  SHDestFolder : Shell32_TLB.Folder;
  SrcDir       : String;
  FileDlg      : TFileOpenDialog;
  RetFlag      : Boolean;
begin
  //初期選択フォルダパス
  SrcDir := ExtractFilePath(Application.ExeName);

  RetFlag := False;

  if CheckWin32Version(6, 0) then begin
    FileDlg := TFileOpenDialog.Create(nil);
    try
      FileDlg.Options := [fdoPickFolders, fdoPathMustExist, fdoForceFileSystem];
      FileDlg.DefaultFolder := SrcDir;
      if FileDlg.Execute then begin
        Update;
        SrcDir := FileDlg.FileName;
        RetFlag := True;
      end;
    finally
      FreeAndNil(FileDlg);
    end;
  end else begin
    //Vista以降で FileCtrl.SelectDirectory('フォルダ指定', '', SrcDir, [sdNewUI])
    //でダイアログを表示すると，指定したフォルダ位置までスクロールしてくれない
    if FileCtrl.SelectDirectory('フォルダ指定', '', SrcDir, []) then begin
      Update;
      RetFlag := True;
    end;
  end;


  if RetFlag then begin
    //フォルダやファイルをシェルオブジェクトとして扱うためのTShell
    SHShell := TShell.Create(Self);

    //圧縮後のファイル名(フルパス)
    //このプロジェクトのフォルダ内のTEMPフォルダ内とする
    //このファイルがないと例外発生
    DestPath := ExtractFilePath(Application.ExeName) + 'TEMP\TestB.ZIP';
    //この名前でZIP書庫ファイルを新規作成
    CreateNewZIPFile(DestPath);

    try
      //作成する書庫ファイルのシェルオブジェクトを取得(フォルダ扱い)
      SHDestFolder := SHShell.NameSpace(DestPath);

      //格納するファイルの基準ディレクトリのシェルオブジェクト
      SHSrcFolder := SHShell.NameSpace(IncludeTrailingPathDelimiter(SrcDir));

      //圧縮(実は単なるコピー)
      SHDestFolder.CopyHere(SHSrcFolder.Items, 0);
    except
      ShowMessage('このシステムでは，この機能は使用できません．　');
      //失敗したので作成したファイルは削除しておく
      SHDeleteFileFolder(DestPath);
    end;
  end;
end;

//=============================================================================
//  ZIP書庫を解凍
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  SrcFile       : String;
  DestFolder    : String;
  SHShell       : Shell32_TLB.TShell;
  SHSrcFolder   : Shell32_TLB.Folder;
  SHDestFolder  : Shell32_TLB.Folder;
begin
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
  OpenDialog1.DefaultExt := 'ZIP';
  OpenDialog1.Filter     := 'ZIP書庫ファイル(*.ZIP)|*.ZIP';
  OpenDialog1.FileName   := '';

  if OpenDialog1.Execute then begin
    Update;

    SrcFile := OpenDialog1.FileName;
    //解凍対象書庫があるフォルダ内に解凍展開
    DestFolder := ExtractFilePath(SrcFile) +
                  ChangeFileExt(ExtractFileName(SrcFile), '') + 'の解凍フォルダ';

    //該当フォルダがない場合は例外発生
    //既に展開済みのファイル等が存在する場合は上書き確認ダイアログ表示するので
    //存在したら削除して再作成
    //ダイアログの表示・非表示はCopyHereメソッドの引数でも指定可能
    if SysUtils.DirectoryExists(DestFolder) then begin
      SHDeleteFileFolder(DestFolder);
    end;
    //ディレクトリの作成
    SysUtils.ForceDirectories(DestFolder);

    //フォルダやファイルをシェルオブジェクトとして扱うためのTShell
    SHShell := TShell.Create(Self);
    try
      try
        //対象書庫ファイルのシェルオブジェクトを取得(フォルダ扱い)
        SHSrcFolder := SHShell.NameSpace(SrcFile);

        //展開先のフォルダのシェルオブジェクトを取得
        SHDestFolder := SHShell.NameSpace(DestFolder);

        //解凍(フォルダ内に書庫のファイル内の各Itemをコピー)
        SHDestFolder.CopyHere(SHSrcFolder.Items, 0);
      except
        ShowMessage('このシステムでは，この機能は使用できません．　');
        //失敗したので作成したフォルダは削除しておく
        SHDeleteFileFolder(DestFolder);
      end;
    finally
      FreeAndNil(SHShell);
    end;
  end;
end;

//=============================================================================
//  空のZIP書庫を作成する関数
//  既存の同名の書庫ファイルは削除される
//=============================================================================
procedure TForm1.CreateNewZIPFile(AFileName: String);
var
  IDData  : array[0..21] of Byte;
  FStream : TFileStream;
  i       : Integer;
begin
  //ZIPファイルの先頭に書き込むバイトデータ
  ZeroMemory(@IDData, Length(IDData) - 1);
  IDData[0] := Byte('P');
  IDData[1] := Byte('K');
  IDData[2] := $05;
  IDData[3] := $06;

  FStream := TFileStream.Create(AFileName,
                                fmCreate or fmOpenReadWrite,
                                fmShareDenyNone);
  try
    for i := 0 to Length(IDData) - 1 do begin
      FStream.Write(IDData[i], 1);
    end;
  finally
    FreeAndNil(FStream);
  end;
end;

//=============================================================================
//  ファイルまたはフォルダの削除
//=============================================================================
procedure TForm1.SHDeleteFileFolder(AFileName: String);
var
  objFileSystem : Scripting_TLB.IFileSystem;
begin
  objFileSystem  := CoFileSystemObject.Create;
  try
    //Trueは読取り専用でも削除の指定
    objFileSystem.DeleteFolder(AFileName, True);
    objFileSystem.DeleteFile(AFileName, True);
  finally
    objFileSystem := nil;
  end;
end;

end.



03_LZH 書庫ファイルの解凍


LZH 書庫の解凍を行うサンプルです．
ZIP ファイルの場合と同じで，LZH 書庫をフォルダとして，書庫内のファイルやフォルダを他のフォルダにコピーします．


図5
設計時画面
図6
LZH ファイル解凍中

リスト2
Windows 7 の LZH 展開機能を使用して LZH 書庫を解凍 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    OpenDialog1: TOpenDialog;
    Button3: TButton;
    procedure Button3Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  Windows 7のLZH解凍機能でLZH書庫を解凍
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  SrcFile       : String;
  DestFolder    : String;
  SHShell       : Shell32_TLB.TShell;
  SHSrcFolder   : Shell32_TLB.Folder;
  SHDestFolder  : Shell32_TLB.Folder;
  objFileSystem : Scripting_TLB.IFileSystem;
begin
  OpenDialog1.InitialDir := ExtractFileDir(ParamStr(0));
  OpenDialog1.DefaultExt := 'LZH';
  OpenDialog1.Filter     := 'LZH書庫ファイル(*.LZH)|*.LZH';

  if OpenDialog1.Execute then begin
    Update;

    SrcFile := OpenDialog1.FileName;
    //解凍対象書庫があるフォルダ内に解凍展開
    DestFolder := ExtractFilePath(SrcFile) +
                  ChangeFileExt(ExtractFileName(SrcFile), '') + 'の解凍フォルダ';

    //該当フォルダがない場合は例外発生
    //既に展開済みのファイル等が存在する場合は上書き確認ダイアログ表示するので
    //存在したら削除して再作成
    if DirectoryExists(DestFolder) then begin
      objFileSystem  := CoFileSystemObject.Create;
      try
        //Trueは読取り専用でも削除の指定
        objFileSystem.DeleteFolder(DestFolder, True);
      finally
        objFileSystem := nil;
      end;
    end;
    //ディレクトリの作成
    ForceDirectories(DestFolder);

    //フォルダやファイルをシェルオブジェクトとして扱うためのTShell
    SHShell := TShell.Create(Self);
    try
      try
        //対象書庫ファイルのシェルオブジェクトを取得(フォルダ扱い)
        SHSrcFolder := SHShell.NameSpace(SrcFile);

        //展開先のフォルダのシェルオブジェクトを取得
        SHDestFolder := SHShell.NameSpace(DestFolder);

        //解凍(フォルダ内に書庫のファイル内の各Itemをコピー)
        SHDestFolder.CopyHere(SHSrcFolder.Items, 0);
      except
        ShowMessage('このシステムでは，この機能は使用できません．　');

        //失敗したので作成したフォルダは削除しておく
        objFileSystem  := CoFileSystemObject.Create;
        try
          objFileSystem.DeleteFolder(DestFolder, True);
        finally
          objFileSystem := nil;
        end;
      end;
    finally
      FreeAndNil(SHShell);
    end;
  end;
end;

end.



04_DLL のバージョンの取得


アプリケーションの動作は，関連する DLL のバージョンによっても違ってくることがあります．そんな時の FileSystemObject を使用した参考用サンプルです．


図7
Scrrun.dll のバージョン
図8
Shell32.dll のバージョン

リスト3
DLL のバージョン番号を取得 
unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses Scripting_TLB, ComObj;

{$R *.dfm}

//=============================================================================
//  Scrrun.dllのバージョンを調査
//
//  IFileSystemを使用
//  usesにComObjとScripting_TLBが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  DllPath        : String;
  objFileSystem  : Scripting_TLB.IFileSystem;
  objFileSystem3 : Scripting_TLB.IFileSystem3;
  objFolder      : Scripting_TLB.IFolder;
begin
  //GetSpecialFolderを使うためにIFileSystemを生成
  //GetFileVerstionというメソッドがIFileSystem3にあるのでそのオブジェクトを生成
  objFileSystem  := CoFileSystemObject.Create;
  objFileSystem3 := CoFileSystemObject.Create;
  try
    //OSのシステムディレクトリを取得
    objFolder := objFileSystem.GetSpecialFolder(SystemFolder);

    //そのディレクトリ下にあるファイルのパスを取得
    DllPath := IncludeTrailingPathDelimiter(objFolder.Path) + 'Scrrun.dll';

    //ファイルのバージョンを表示
    ShowMessage(objFileSystem3.GetFileVersion(DllPath));
  finally
    objFileSystem  := nil;
    objFileSystem3 := nil;
  end;
end;

//=============================================================================
//  Shell32.dllのバージョンを調査
//
//  IFileSystemを使用
//  usesにComObjとScripting_TLBが必要
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  DllPath        : String;
  objFileSystem  : Scripting_TLB.IFileSystem;
  objFileSystem3 : Scripting_TLB.IFileSystem3;
  objFolder      : Scripting_TLB.IFolder;
begin
  //GetSpecialFolderを使うためにIFileSystemを生成
  //GetFileVerstionというメソッドがIFileSystem3にあるのでそのオブジェクトを生成
  objFileSystem  := CoFileSystemObject.Create;
  objFileSystem3 := CoFileSystemObject.Create;
  try
    //OSのシステムディレクトリを取得
    objFolder := objFileSystem.GetSpecialFolder(SystemFolder);

    //そのディレクトリ下にあるファイルのパスを取得
    DllPath := IncludeTrailingPathDelimiter(objFolder.Path) + 'Shell32.dll';

    //ファイルのバージョンを表示
    ShowMessage(objFileSystem3.GetFileVersion(DllPath));
  finally
    objFileSystem  := nil;
    objFileSystem3 := nil;
  end;
end;

end.



05_CAB 形式ファイルの扱い


エクスプローラでは，CAB 形式書庫も展開できますが，TFileStream 関係のオブジェクトでは操作できません．
Windows には CAB 書庫解凍専用の SetupIterateCabinet 関数があります．この関数はコールバック関数内で解凍するファイルの処理を行います．SetupIterateCabinet 関数は Delphi XE には実装されてませんが，JEDI の API Library には実装されています．