Delphi Programming / Object Pascal
サイトのトップページへ リンクのページへ ロゴマーク
[掲載 2007年04月01日] [更新 2013年02月09日]　Delphi サンプルプログラム集
740_圧縮ファイルの作成 ( 統合アーカイバコンポーネント使用 )
動作確認等 Windows 7 U64(SP1) + Delphi 2007-R2 + UNLHA32.DLL 2.64
総合アーカイバコンポーネント (ARCHIVES)　v1.50 - Delphi 2007 以前用
740_CompressFiles.zip　[928 KB]　2013年02月09日版 (EXE 同梱)



  • 2009年10月25日
  • nana さん開発の [圧縮ファイルツリービュー/リストビュー] コンポーネントの同梱と，それに伴う記事の修正
  • 2013年02月09日
  • Delphi 2007 R-2 で動作確認
  • 記事の修正等



圧縮ファイルの作成 ( 統合アーカイバコンポーネント使用 )


米田昌司さんが開発した [統合アーカイバコンポーネント for Delphi/C++Builder] を使用したサンプルです．このコンポーネントは，現在，正式には入手できませんが，作者が Delphian World 登録用に置いたものが Internet Archive からダウンロードできます．Delphian World は，国内最大のコンポーネントの登録サイトでしたが，現在は存在していません．

統合アーカイバコンポーネントでは，いろいろな形式を扱えますが，ここでは，例として LZH，自己解凍形式の圧縮ファイルを作成，解凍をテストします．
UNLHA32.DLL は，EXE のあるフォルダ内に置いてテストしてください．DLL は [統合アーカイバ・プロジェクト] のサイトの [個別ライブラリ] のページから入手できます．
以下のコードは，コンポーネントのサンプルでも紹介されているものですが，それらを更に簡略化したものです．
UNLHA32.DLL の使用については，[731_UNLHA32.DLL を使用したファイルの圧縮・解凍] の記事も参考にしてください．


[備考]
総合アーカイバコンポーネント (ARCHIVES) は，Delphi 2009 以降では使用できません．修正すれば使用可能ですが，このコンポーネントの再配布は作者への連絡が必要となっています．また，改変したコードの配布は禁止となっています．



図1
設計時画面
  • 総合アーカイバコンポーネントはインストールしないで，uses に追加して利用
  • 進行ダイアログ等，また独自のダイアログを使用する場合は，コンポとして配置して利用した方が良い
図2
[選択ファイル圧縮]
  • ファイル選択ダイアログで選択した複数のファイルを，拡張子が lzh の圧縮ファイルにする
  • 保存場所は，このプロジェクトのフォルダ
図3
[指定フォルダ内圧縮]
  • フォルダ選択ダイアログで選択したフォルダ内のファイル (サブフォルダも含む) を圧縮する
  • 拡張子は lzh で，保存先はこのプロジェクトのフォルダ
図4
[自己解凍形式に変換]
  • 図1 または 図2 で作成した圧縮ファイルを，自己解凍形式に変換する
図5
[自己解凍自動実行形式に変換]
  • 図1 または 図2 で作成した圧縮ファイルを，自己解凍実行形式に変換する
  • 自動実行対象は，フォルダ BBB 内の BB1.TXT
図6
実行結果
  • 以上を実行した結果のプロジェクト内のファイル
  • TestA.lzh, TestB.lzh が作成した圧縮ファイル
  • TestA.EXE は，TestA.lzh から作成した自己解凍形式ファイル
  • TextB.EXE は，TestB.lzhから作成した自己解凍形式ファイル
図7
TestB.EXE を実行
  • 解凍先を指定するダイアログが表示される
図8
自動実行ファイルを指定している場合
  • 解凍後に該当アプリケーションが起動する
  • ここでは，テキストファイルなので，筆者の環境ではテキストエディタが起動する

リスト1
統合アーカイバコンポーネントを使用した圧縮と解凍 
unit CompressFilesUnit;

interface

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

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

var
  Form1: TForm1;

implementation

uses FileCtrl;

{$R *.DFM}

//=============================================================================
//  選択ファイル(のみ)の圧縮
//
//  DestFile : 圧縮後のファイル名(フルパス)
//  Arc      : 総合アーカイバコンポーネント
//  FileList : TOpenDialogで選択したファイルのリスト
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  DestFile : String;
  Arc      : TArchiveFile;
  FileList : TStringList;
begin
  //圧縮後のファイル名(フルパス)
  DestFile               := ExtractFilePath(Application.ExeName) + 'TestA.lzh';
  OpenDialog1.Options    := OpenDialog1.Options + [ofAllowMultiSelect];
  OpenDialog1.InitialDir := ExtractFilePath(Application.ExeName) + 'AAA';
  OpenDialog1.Filter     := '';
  OpenDialog1.FileName   := '';

  if OpenDialog1.Execute then begin
    Filelist := TStringList.Create;
    Filelist.AddStrings(OpenDialog1.Files);

    Arc := TArchiveFile.Create(self);
    try
      Arc.FileName    := DestFile; //作成するファイル名
      Arc.Options.a   := 1;        //隠し属性やsytemファイルも取り込む
      Arc.Options.c   := 1;        //上書き
      Arc.Options.n   := 1;        //経過表示のダイアログなし
      Arc.OutputSize  := 8192;     //バッファサイズ
      Arc.Options.jso := 0;        //読込み許可で開けなかったファイルはエラー扱い

      //圧縮実行
      Arc.PackFiles(Handle, nil, '', [Filelist]); //圧縮実行
    finally
      FreeAndNil(Arc);
      FreeAndNil(FileList);
    end;
  end;
end;

//=============================================================================
//  選択したフォルダ内を圧縮(サブフォルダとファイル)
//
//  DestFile : 圧縮後のファイル名(フルパス)
//  BaseDir  : 圧縮ファイルを作成するフォルダ名
//  Arc      : 総合アーカイバコンポーネント
//  FileList : TOpenDialogで選択したファイルのリスト
//
//  SelectDirectoryの使用にはusesにFileCtrlが必要
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  DestFile : String;
  Arc      : TArchiveFile;
  FileList : TStringList;
  BaseDir  : string;
begin
  DestFile := ExtractfilePath(Application.ExeName) + 'TestB.lzh';
  BaseDir  := ExtractfilePath(Application.ExeName) + 'AAA';

  if SelectDirectory('圧縮対象フォルダを選択', '', BaseDir) then begin
    FileList := TStringList.Create;
    FileList.Add('*.*');
    Arc := TArchiveFile.Create(self);
    try
      Arc.FileName    := DestFile; //作成するファイル名(フルパス)
      Arc.Options.x   := 1;        //ディレクトリ情報を記録
      Arc.Options.a   := 1;        //隠し属性やsytemファイルも取り込む
      Arc.Options.c   := 1;        //上書き
      Arc.Options.r   := 1;        //再帰的検索(サブフォルダも圧縮)
      Arc.Options.n   := 1;        //経過表示のダイアログなし
      Arc.OutputSize  := 8192;     //出力バッファサイズを指定
      Arc.Options.jso := 0;        //読込み許可で開けなかったファイルはエラー扱い

      //圧縮実行
      Arc.PackFiles(Handle, nil, BaseDir, [Filelist]);
    finally
      FreeAndNil(Arc);
      FreeAndNil(FileList);
    end;
  end;
end;

//=============================================================================
//  lzhファイルを自動解凍形式に変換
//  対象のlzhファイルをファイル選択ダイアログで選択
//
//  ArchiveFile : 総合アーカイバコンポーネント
//  SrcFile     : 自動解凍形式にするlzhファイル
//  DestDir     : 作成した自動実行形式ファイルを置くフォルダ
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  ArchiveFile : TArchiveFile;
  SrcFile     : String;
  DestDir     : String;
begin
  DestDir                := ExtractFileDir(Application.ExeName);
  OpenDialog1.Options    := OpenDialog1.Options - [ofAllowMultiSelect];
  OpenDialog1.InitialDir := ExtractFilePath(Application.ExeName);
  OpenDialog1.Filter     := '圧縮ファイル|*.lzh';
  OpenDialog1.FileName   := '';

  if OpenDialog1.Execute then begin
    ArchiveFile := TArchiveFile.Create(Self);
    SrcFile     := OpenDialog1.FileName;
    try
      ArchiveFile.FileName    :=  SrcFile; //圧縮済みのファイル名
      ArchiveFile.Options.x   :=  1;       //ディレクトリ情報を残す
      ArchiveFile.Options.gw  :=  2;       //WinSFX32M 形式
      ArchiveFile.Options.jso :=  1;       //共有エラーの場合に処理を続行
      ArchiveFile.OutputSize  :=  8192;    //出力バッファサイズを指定
      ArchiveFile.Options.n   :=  1;       //解凍時の経過表示なし
      ArchiveFile.Options.jyo :=  1;       //解凍時上書き確認のみなし

      //変換実行
      ArchiveFile.MakeSfx(Handle, nil, DestDir);
    finally
      ArchiveFile.Free;
    end;
  end;
end;

//=============================================================================
//  lzhファイルを自動解凍形式に変換し，自動実行コマンドを指定
//  対象のlzhファイルをファイル選択ダイアログで選択
//
//  自動実行コマンドの実行は，ShellExecuteにより行われるので，関連づけがされて
//  いれば直接ファイル名を指定することが可能．ここではテキストファイルを指定．
//
//  ArchiveFile : 総合アーカイバコンポーネント
//  SrcFile     : 自動解凍形式にするlzhファイル
//  DestDir     : 作成した自動実行形式ファイルを置くフォルダ
//=============================================================================
procedure TForm1.Button4Click(Sender: TObject);
var
  ArchiveFile : TArchiveFile;
  SrcFile     : String;
  DestDir     : String;
begin
  DestDir                := ExtractFileDir(Application.ExeName);
  OpenDialog1.Options    := OpenDialog1.Options - [ofAllowMultiSelect];
  OpenDialog1.InitialDir := ExtractFilePath(Application.ExeName);
  OpenDialog1.Filter     := '圧縮ファイル|*.lzh';
  OpenDialog1.FileName   := '';

  if OpenDialog1.Execute then begin
    ArchiveFile := TArchiveFile.Create(Self);
    SrcFile     := OpenDialog1.FileName;
    try
      ArchiveFile.FileName    := SrcFile;       //圧縮済みのファイル名
      ArchiveFile.Options.x   := 1;             //ディレクトリ情報を残す
      ArchiveFile.Options.gw  := 2;             //WinSFX32M 形式
      ArchiveFile.Options.jso := 1;             //共有エラーの場合に処理を続行
      ArchiveFile.OutputSize  := 8192;          //出力バッファサイズを指定
      ArchiveFile.Options.n   := 1;             //解凍時の経過表示なし
      ArchiveFile.Options.jyo := 1;             //解凍時上書き確認のみなし
      ArchiveFile.Options.gyq := 0;             //解凍後自動実行を行う
      ArchiveFile.Options.gye := 'BBB\BB1.txt'; //解凍後の自動実行コマンド

      //変換実行
      ArchiveFile.MakeSfx(Handle, nil, DestDir);
    finally
      ArchiveFile.Free;
    end;
  end;
end;

end.



圧縮ファイル ( 書庫 ) のファイルをリスト表示


統合アーカイバコンポーネントを使用すると，圧縮ファイル(書庫)内のファイルをリスト表示することもできます．しかし，結構面倒なので，ここでは，NanaTree の作者である nana さんが開発した [圧縮ファイルツリービュー/リストビュー] コンポーネントを利用することにしました．


  • 図9設計時画面
  • 左がフォルダ表示用，右がファイルリスト表示用のコンポーネント
  • クラス名は，TArcTreeView と TArcListView

  • 図10実行画面例
  • カラムのクリックでソートができる

リスト2
圧縮ファイル (書庫) をリスト表示 
unit CompressFilesListUnit;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    StatusBar1: TStatusBar;
    ArcTreeView1: TArcTreeView;
    Splitter1: TSplitter;
    ArcListView1: TArcListView;
    Button1: TButton;
    OpenDialog1: TOpenDialog;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure ArcListView1DblClick(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//=============================================================================
//  各種初期設定
//=============================================================================
procedure TForm1.FormCreate(Sender: TObject);
begin
  Panel1.Caption := '';

  //右のリストビューの表示形式はvsReportとする
  ArcListView1.ViewStyle := vsReport;
  //リストビューにはArcTreeView1のフォルダのファイル一覧を表示
  ArcListView1.ArcTreeView := ArcTreeView1;

  //ツリーの最上部にファイル名を表示
  ArcTreeView1.ShowAllList := True;
  //ツリービューにノードを表示
  ArcTreeView1.ShowTrees   := True;
  //リストビューにフォルダも表示
  ArcListView1.ShowFolder  := True;
end;

//=============================================================================
//  ファイル選択ダイアログでファイル選択
//  ZIPファイルを扱うには，UNZIP.dllがパスの通ったフォルダに必要
//  LZHファイルを扱うには，UNLHA32.dllがパスの通ったフォルダに必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
  OpenDialog1.Filter     := '圧縮ファイル|*.lzh;*.zip';
  if OpenDialog1.Execute then begin
    Update;

    Screen.Cursor := crHourGlass;
    //表示するLZHまたはZIPファイル
    ArcTreeView1.ArchiveFilePath := OpenDialog1.FileName;
    //ルートを表示する
    //この指定がない場合は圧縮ファイル内の全ファイルリストをListViewに表示
    ArcTreeView1.ArchiveTreePath := 'Root/';
    Screen.Cursor := crDefault;
  end;
end;

//=============================================================================
//  右のリストビューをクリックした時
//=============================================================================
procedure TForm1.ArcListView1DblClick(Sender: TObject);
var
  AItem: TListItem;
begin
  AItem := ArcListView1.Selected;
  if AItem = nil then Exit;

  //フォルダの場合そのフォルダ内を表示
  if AItem.Data = nil then begin
    ArcListView1.ArchiveTreePath :=
       (ArcListView1.ArchiveTreePath + AItem.Caption + '/');
  end else begin
    //フォルダ以外の時の処理をここに書く
    //nanaさん提供のサンプルプログラムのコードを参考のこと
  end;
end;

end.



Delphi 2007 のデバッガのエラー  -  Windows 7 64bit 版


Delphi 2007 を，Windows 7 の 64bit 版で起動して，プログラムを実行すると，終了時に次のようなエラーが発生する場合があります． 

Assertion failure: "(!"SetThreadContext failed")"
in ..\win32src\thread32.cpp at line 412
Continue execution?

この場合，27521_rad_studio_2007_debugger_fix_for_windows_7.ZIP を以下のリンクからダウンロードし，解凍した bordbk105N.dll を Delphi 2007 の bin フォルダにコピーします．bin フォルダは，デフォルトで以下にあります． 

C:\Program Files (x86)\CodeGear\RAD Studio\5.0\bin

図11
デバッガのエラー