[ 731_UNLHA32.DLL を使用したファイルの圧縮・解凍 ]

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Memo1: TMemo;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    Button5: TButton;
    OpenDialog1: TOpenDialog;
    Panel2: TPanel;
    ProgressBar1: TProgressBar;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
  private
    { Private 宣言 }
  protected
    procedure WndProc(var Message: TMessage); override;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses
  FileCtrl;

{$R *.dfm}

//=============================================================================
//  LZH書庫圧縮
//  選択したファイルのみを圧縮
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
  BaseDir   : String;
  DestFile  : String;
  Arch      : TplArchieverLZH;
  FileList  : TStringList;
  ResultMsg : string;
begin
  BaseDir := ExtractFilePath(Application.ExeName);

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

  if not OpenDialog1.Execute then exit;

  Filelist := TStringList.Create;
  Arch     := TplArchieverLZH.Create(Self);
  try
    //圧縮対象ファイル
    FileList.AddStrings(OpenDialog1.Files);
    //圧縮後のファイル名(フルパス)
    //PackFilesメソッドはフォルダがないと失敗するので注意
    DestFile := BaseDir + 'TEST_A\TestA.LZH';

    //圧縮
    Arch.PackFiles(FileList, DestFile, ResultMsg);
  finally
    FreeAndNil(Arch);
    FreeAndNil(FileList);
  end;

  //結果を表示(UNLHA32.DLLからのメッセージ)
  Memo1.Clear;
  Memo1.Text := ResultMsg;
end;

//=============================================================================
//  LZH書庫圧縮
//  選択フォルダ(ディレクトリ)下のファイルとフォルダを圧縮
//  TplArchieverLZHのPackFilesメソッドは2種類あり，こちらは圧縮するファイル
//  (第1引数)をディレクトリ名またはファイル名を1つだけ渡すメソッド
//=============================================================================
procedure TForm1.Button2Click(Sender: TObject);
var
  SrcDir    : String;
  DestFile  : String;
  Arch      : TplArchieverLZH;
  FileDlg   : TFileOpenDialog;
  RetFlag   : Boolean;
  ResultMsg : String;
begin
  //初期選択フォルダパス
  SrcDir  := ExtractFilePath(Application.ExeName) + 'AAA';

  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
    Arch := TplArchieverLZH.Create(Self);
    try
      //圧縮後のファイル名(フルパス)
      //このプロジェクトのフォルダ直下のTEST_Bフォルダ内とする
      //PackFilesメソッドはフォルダがないと失敗するので注意
      DestFile := ExtractFilePath(Application.ExeName) + 'TEST_B\TestB.LZH';

      //圧縮
      Arch.PackFiles(SrcDir, DestFile, ResultMsg);
    finally
      FreeAndNil(Arch);
    end;

    //結果を表示(UNLHA32.DLLからのメッセージ)
    Memo1.Clear;
    Memo1.Text := ResultMsg;
  end;
end;

//=============================================================================
//  LZH書庫を解凍
//=============================================================================
procedure TForm1.Button3Click(Sender: TObject);
var
  Arch      : TplArchieverLZH;
  SrcFile   : String;
  DestFile  : String;
  ResultMsg : string;
begin
  OpenDialog1.InitialDir := ExtractFileDir(Application.ExeName);
  OpenDialog1.DefaultExt := 'LZH';
  OpenDialog1.Filter     := 'LZH|*.LZH';
  OpenDialog1.FileName   := '';

  if not OpenDialog1.Execute then exit;

  Arch := TplArchieverLZH.Create(Self);
  try
    SrcFile := OpenDialog1.FileName;
    //このプロジェクト直下のTempフォルダ内に解凍
    //PackFilesメソッドはフォルダがないと失敗するので注意
    DestFile := ExtractFilePath(ParamStr(0))+ 'Temp';

    //解凍
    Arch.UnPackFiles(SrcFile, DestFile, ResultMsg);
  finally
    FreeAndNil(Arch);
  end;

  //結果を表示(UNLHA32.DLLからのメッセージ)
  Memo1.Clear;
  Memo1.Text := ResultMsg;
end;

//=============================================================================
//  LZH書庫ファイルから自己解凍書庫作成
//
//  実行ファイルを指定すると，そのファイルを拡張子の関連付けで実行する
//  書庫内に該当ファイルがない場合は実行しない
//  書庫作成時の進行ダイアログは表示
//=============================================================================
procedure TForm1.Button4Click(Sender: TObject);
var
  Arch      : TplArchieverLZH;
  SrcFile   : String;
  DestFile  : String;
  RunFile   : String;
  ResultMsg : string;
begin
  OpenDialog1.InitialDir := ExtractFileDir(Application.ExeName);
  OpenDialog1.DefaultExt := 'LZH';
  OpenDialog1.Filter     := 'LZH|*.LZH';
  OpenDialog1.FileName   := '';

  if not OpenDialog1.Execute then exit;

  Arch := TplArchieverLZH.Create(Self);
  try
    SrcFile := OpenDialog1.FileName;
    //LZH書庫ファイルのある場所に
    //Vista以降では，フォルダ指定は無効．常にプロジェクトのルートとなる
    DestFile := ExtractFilePath(SrcFile) + 'ABC.EXE';
    //解凍時の実行ファイル
    RunFile := 'AA1.txt';

    //作成
    Arch.MakeSFX(SrcFile, DestFile, RunFile, ResultMsg);
  finally
    FreeAndNil(Arch);
  end;

  //結果を表示(UNLHA32.DLLからのメッセージ)
  Memo1.Clear;
  Memo1.Text := ResultMsg;
end;

//=============================================================================
//  UNLHA32.DLLのバージョン表示
//=============================================================================
procedure TForm1.Button5Click(Sender: TObject);
var
  Arch : TplArchieverLZH;
begin
  Arch := TplArchieverLZH.Create(Self);
  try
    ShowMessage(Arch.GetVersion);
  finally
    FreeAndNil(Arch);
  end;
end;

//=============================================================================
//  TForm1のWndProcメソッド
//  WndProcメソッドは当サイトの他のサンプルまたはDelphiのヘルプ参照
//  7-zip32.DLLからのメッセージ処理
//  圧縮または解凍作業中に送信してくるWM_ARCEXTRACTメッセージを処理
//
//  WParam  進行状況を表すメッセージ値(本コードの先頭部参照)
//  LParam  EXTRACTINGINFO構造体のポインタ(本コードの先頭部参照)
//=============================================================================
procedure TForm1.WndProc(var Message: TMessage);
var
  State : UINT;
  lpEis : LPExtractingInfo;
begin
  inherited;

  if Message.Msg = WM_ARCEXTRACT then begin
    State := Message.wParam;
    lpEis := LPExtractingInfo(Message.lParam);

    if State = ARCEXTRACT_OPEN then begin
      ProgressBar1.Position := 0;
    end else
    if State = ARCEXTRACT_INPROCESS then  begin
      //この処理は格納ファイルごとになるので，全体の割合を表示するには，最初に　
      //ファイル数やファイルサイズを取得しておく必要がある
      ProgressBar1.Position := Trunc(lpEis.dwWriteSize / lpEis.dwFileSize * 100);
    end;

    //処理継続(Message.Result := 1とすれば処理中止)
    Message.Result := 0;
  end;
end;

end.

unit plArchieverLZH;

interface

uses
    Windows, SysUtils, Classes, Controls;

const
  //外部で使用する定数(EXTRACTINGINFO構造体用)
  FNAME_MAX32 = 513 -1;
  ARCEXTRACT_BEGIN     = 0; //該当ファイルの処理開始
  ARCEXTRACT_INPROCESS = 1; //該当ファイルの展開中
  ARCEXTRACT_END       = 2; //処理終了.関連メモリを開放
  ARCEXTRACT_OPEN      = 3; //該当書庫の処理の開始
  ARCEXTRACT_COPY      = 4; //ワークファイルの書き戻し

//-----------------------------------------------------------------------------
//  進行状況の情報格納用構造体の定義
//  Delphi2009以降の使用を考慮してAnsiCharと明記
//  格納ファイルサイズと書き込んだサイズはファイル1つ1つの値(全体ではない)
//-----------------------------------------------------------------------------
type
  PEXTRACTINGINFO = ^TEXTRACTINGINFO;
  TEXTRACTINGINFO = record
    dwFileSize       : DWORD;                                //格納ファイルサイズ
    dwWriteSize      : DWORD;                                //書き込んだサイズ
    szSourceFileName : array [0..FNAME_MAX32-1] of AnsiChar; //処理中のファイル名
    dummy1           : array [0..2] of AnsiChar;             //ダミー
    szDestFileName   : array [0..FNAME_MAX32-1] of AnsiChar; //そのフルパス
    dummy            : array [0..2] of AnsiChar;             //ダミー
  end;
  LPEXTRACTINGINFO = ^TExtractingInfo;

//-----------------------------------------------------------------------------


var
  //このユニットを使用するアプリ側で受取る進行状況用メッセージ定義
  WM_ARCEXTRACT : Cardinal;

type
  TplArchieverLZH = class(TComponent)
  private
    FHandle : HWND;
  protected
    FDllHandle : THandle;
    function Execute(Cmd: String; var AMsg: String): Boolean;
    function AddQuotedStr(Str: String): String;
    function GetBasePath(PathList: TStrings): String;
  public
    constructor Create( AOwner:TComponent ); override;
    destructor Destroy(); override;
    function PackFiles(SrcPathList: TStrings; DestFile: String;
      var AMsg: String): Boolean; overload;
    function PackFiles(SrcPath, DestPath: String; var AMsg: String):
      Boolean; overload;
    function UnPackFiles(SrcPath, DestPath: String; var AMsg: String): Boolean;
    function MakeSFX(SrcPath, DestPath: String; AutoRunFile: String;
      var AMsg: String): Boolean;
    function GetVersion: String;
  end;

implementation

{ TplArchieverLZH }

type
  TUnlha          = function (const hWnd: HWND; szCmdLine: LPCSTR; 
                              szOutput: LPSTR; dwSize: DWORD): Integer; stdcall;
  TUnlhaSetOwnerWindow   = function(_hwnd: HWND) : BOOL; stdcall;
  TUnlhaClearOwnerWindow = function() : BOOL; stdcall;
  TUnlhaGetVersin        = function (): WORD; stdcall;

var
  FUnlha                 : TUnlha;
  FUnlhaSetOwnerWindow   : TUnlhaSetOwnerWindow;
  FUnlhaClearOwnerWindow : TUnlhaClearOwnerWindow;
  FUnlhaGetVersion       : TUnlhaGetVersin;

const
  BUFF_SIZE = 8192;

//=============================================================================
//  Create処理
//=============================================================================
constructor TplArchieverLZH.Create(AOwner:TComponent);
begin
  inherited;

  FDllHandle := LoadLibrary('UNLHA32.DLL');
  if FDllHandle < HINSTANCE_ERROR then begin
    FDllHandle := 0;
  end else begin
    FHandle := TWinControl(AOwner).Handle;

    if WM_ARCEXTRACT = 0 then
      WM_ARCEXTRACT := RegisterWindowMessage('wm_arcextract');

    @FUnlha                 := GetProcAddress(FDllHandle, 'Unlha');
    @FUnlhaSetOwnerWindow   := GetProcAddress(FDllHandle, 'UnlhaSetOwnerWindow');
    @FUnlhaClearOwnerWindow := GetProcAddress(FDllHandle, 'UnlhaClearOwnerWindow');
    @FUnlhaGetVersion := GetProcAddress(FDllHandle, 'UnlhaGetVersion');

    FUnlhaSetOwnerWindow(FHandle);
  end;
end;

//=============================================================================
//  Destroy処理
//=============================================================================
destructor TplArchieverLZH.Destroy;
begin
  if FDllHandle <> 0 then FreeLibrary(FDllHandle);
  FDllHandle := 0;

  inherited;
end;

//=============================================================================
//  圧縮メソッド
//  同じ名前で格納ファイルを変更する場合は書庫ファイルを削除しないと前のファイ
//  ルが残ったままとなる
//
//  SrcPathList
//    圧縮対象のファイルまたはディレクトリのリスト．フルパスで指定
//    または基準ディレクトリを除いたパス名で指定する
//  DestFile
//    圧縮後のファイル名．フルパスで指定する．拡張子を省略するとLZHになる
//  AMsg
//    UNLHA32.DLLが返すメッセージ文字列
//
//  HogeDirのようなディレクトリも含める場合は以下のようにする
//  パス名の最後のデリミタ(\)の有無は問わない
//  [例]
//  SrcPathList.Add('D:\000\AAA.txt');
//  SrcPathList.Add('D:\000\BBB.doc');
//  SrcPathList.Add('D:\000\CCC.xls');
//  SrcPathList.Add('D:\000\HogeDir');
//=============================================================================
function TplArchieverLZH.PackFiles(SrcPathList: TStrings; DestFile: String;
  var AMsg: String): Boolean;
var
  BasePath  : String;
  Str       : String;
  FListStr  : String;
  i         : Integer;
  FCommand  : String;
begin
  Result := False;
  //DLLがロードできていないかロードに失敗
  if FDllHandle = 0 then exit;

  FListStr := '';
  if SrcPathList.Count = 1 then begin
    BasePath := ExcludeTrailingPathDelimiter(SrcPathList[0]);
    if DirectoryExists(BasePath) then begin
      BasePath := IncludeTrailingPathDelimiter(SrcPathList[0]);
      FListStr := '*';
    end else begin
      BasePath := ExtractFilePath(SrcPathList[0]);
      FListStr := AddQuotedStr(ExtractFileName(SrcPathList[0]));
    end;
  end else begin
    //基準ディレクトリを求め，その基準ディレクトリを削除したパス名リストを作成
    BasePath := GetBasePath(SrcPathList);

    //UNLHA32.DLLの関数に渡す"で囲んだ文字列を作成(空白があることを考慮して)
    for i := 0 to SrcPathList.Count - 1 do begin
      Str := SrcPathList[i];
      FListStr := FListStr + AddQuotedStr(ExcludeTrailingPathDelimiter(Str)) + ' ';
    end;
  end;

  FCommand := 'a -a1 -r2 -x1 -l1 -jp0 -n1 ' +
              AddQuotedStr(DestFile) + ' '+
              AddQuotedStr(BasePath) + ' '+
              FListStr;

  Result := Execute(FCommand, AMsg);
end;

//=============================================================================
//  圧縮メソッド
//  単一ディレクトリまたは単一ファイル用
//=============================================================================
function TplArchieverLZH.PackFiles(SrcPath, DestPath: String;
  var AMsg: String): Boolean;
var
  SL : TStringList;
begin
  SL := TStringList.Create;
  try
    SL.Add(SrcPath);
    Result := PackFiles(SL, DestPath, AMsg);
  finally
    FreeAndNil(SL);
  end;
end;

//=============================================================================
//  解凍メソッド
//  解凍時の進捗バーをプログレスバー非表示で上書きモード
//  ただし読取り専用ファイルの場合は，確認のダイアログを表示する
//
//  SrcPath
//    解凍対象のファイルのフルパス
//  DestPath
//    解凍後先のディレクトリ名(最後にデリミタは不要)
//    存在しないディレクトリを指定すると解凍しない(AMsgに空文字を返す)
//  AMsg
//    UNLHA32.DLLが返すメッセージ文字列
//=============================================================================
function TplArchieverLZH.UnPackFiles(SrcPath, DestPath: String;
  var AMsg: String): Boolean;
var
  FCommand : String;
begin
  //DLLがロードできていないかロードに失敗
  Result := False;
  if FDllHandle = 0 then exit;

  FCommand := 'e '+ '-a1 -r2 -x1 -jp0 -c1 -m1 -n1 ' +
              AddQuotedStr(SrcPath) + ' ' +
              AddQuotedStr(IncludeTrailingPathDelimiter(DestPath));

  //引数を与えて関数を実行
  Result := Execute(FCommand, AMsg);
end;

//=============================================================================
//  自己解凍書庫の作成(WinSFX32M形式)
//  作成した書庫の展開先はこの書庫があるディレクトリ内
//  Windows 7 U64の場合にはプロジェクトのフォルダ内となる)
//
//  SrcPath
//    既に作成したLZH書庫ファイルのフルパス
//  DestPath
//    作成する自己解凍書庫ファイルのパス名．フルパスを指定してもSrcPathと同じ
//    ディレクトリ内に作成される
//    空白文字列にするとSrcPathのファイル名の拡張子をEXEにしたものとなる
//  AutoRunFile
//    作成した自動解凍書庫を解凍後に自動実行するファイルの指定
//    指定しない場合は空文字とする
//  AMsg
//    UNLHA32.DLLが返すメッセージ文字列
//=============================================================================
function TplArchieverLZH.MakeSFX(SrcPath, DestPath: String;
  AutoRunFile: String; var AMsg: String): Boolean;
var
  FCommand    : String;
  ADestPath   : String;
  SavePath    : String;
  SL          : TStringList;
begin
  Result := False;
  //DLLがロードできていないかロードに失敗
  if FDllHandle = 0 then exit;
  //作成元のファイルがない
  if FileExists(SrcPath) = False then exit;

  ADestPath := ExtractFileName(DestPath);
  if Trim(ADestPath) = '' then 
    ADestPath := ChangeFileExt(ExtractFileName(SrcPath), '.EXE');

  FCommand := 's -gx11 -gw4 '+ AddQuotedStr(SrcPath) +
              ' -x1 -r2 -gr' + AddQuotedStr(ADestPath);

  Result := True;
  if AutoRunFile <> '' then begin
    SL := TStringList.Create;
    SavePath := ExtractFilePath(SrcPath) + '$';

    try
      SL.Add('$Command=' + AddQuotedStr(AutoRunFile));
      SL.SaveToFile(SavePath);
      //引数を与えて関数を実行(解凍時の自動実行用ファイルの追加)
      Result := Execute('a '+ SrcPath + ' ' + AddQuotedStr(SavePath), AMsg);
    finally
      DeleteFile(SavePath);
      FreeAndNil(SL);
    end;
  end;

  //引数を与えて関数を実行
  if Result then begin
    AMsg := '';
    Result := Execute(FCommand, AMsg);
  end;
end;

//=============================================================================
//  圧縮または解凍の実行ルーチン
//  圧縮か解凍かは引数のコマンドで決まる
//  引数のAMsgに結果の文字列を戻す
//  成功しなかった場合でも，AMsgが空の場合があるので注意
//
//  UNLHA32.DLLはUnicode(ユニコード)対応ではないので，この関数内では文字列を
//  AnsiStringに変換している
//=============================================================================
function TplArchieverLZH.Execute(Cmd: String; var AMsg: String): Boolean;
var
  ACommand : AnsiString;
  Output   : array[0..BUFF_SIZE-1] of AnsiChar;
begin
  Result := False;

  if @FUnlha <> nil then begin
    FillChar(Output, SizeOf(Output), 0);
    //ヒントや警告が表示されるので明示的にキャストしておく
    ACommand := AnsiString(Cmd);
    try
      FUnlha(FHandle, PAnsiChar(ACommand), OutPut, BUFF_SIZE);
      Result := True;
    except
    end;
  end;
  AMsg := String(OutPut);
end;

//=============================================================================
//  UNLHA32.DLLのバージョン文字列を取得
//=============================================================================
function TplArchieverLZH.GetVersion: String;
var
  VerWORD : WORD;
begin
  if @FUnlhaGetVersion <> nil then begin
    try
      VerWORD := FUnlhaGetVersion;
      Result  := 'Ver. ' + FormatFloat('#.##' , VerWORD / 100);
    except
    end;
  end;
end;

//=============================================================================
//  PathListのフルパス文字列から，先頭が一致するディレクトリ名を切出す
//  PathListにはそ基準ディレクトリを削除したパス名を返す
//
//  ファイルのリストの基準ディレクトリを取得
//  圧縮はこの基準ディレクトリ階層下にあるものだけと仮定する
//  パスを比較して一番短いものを基準ディレクトリとする
//  ただし念のため先頭からのディレクトリ名で比較する
//  長さで比較するとD:\000\BBBBBBとD:\000\A\C とでは後者が短くなってしまう
//
//  UNLHA32.DLLにはファイル数等の制限があり，コマンドラインでのパラメータ数は
//  2048なので，ディレクトリ内のファイルはフルパスで全て与えるのではなく，
//  ディレクトリ名を与えた方がよい．この制限はレスポンスファイルを使えば事実上
//  パラメータ数に制限はなくなる
//=============================================================================
function TplArchieverLZH.GetBasePath(PathList: TStrings): String;
var
  i     : integer;
  APath : String;
  Str   : String;
  ALen  : Integer;
begin
  Result := '';
  if (PathList.Count = 0) then exit;;

  //ExtractFileDirでは更に上の階層になってしまう
  APath := ExtractFilePath(ExcludeTrailingPathDelimiter(PathList[0]));

  for i := 0 to PathList.Count - 1 do begin
    Str := ExtractFilePath(ExcludeTrailingPathDelimiter(PathList[i]));

    //APathの文字列を比較
    //等しくない場合はStrの方が短いパスなのでAPathを1つ上の階層に移動して短くする
    //これを一致するまで繰り返す
    while True do begin
      ALen := Length(APath);
      if (Copy(Str, 1, ALen) = APath) then begin
        break;
      end else begin
        APath := ExtractFilePath(ExcludeTrailingPathDelimiter(APath));
      end;
    end;
  end;
  Result := APath;

  //基準ディレクトリ階層下のファイルやディレクトリのみを対象とするので
  //基準ディレクトリを除いたパス名をPahtListに格納する
  ALen := Length(Result);
  for i := 0 to PathList.Count - 1 do begin
    Str := PathList[i];
    if Copy(Str, 1, ALen) = Result then begin
      System.Delete(Str, 1, ALen);
      PathList[i] := Str;
    end;
  end;
end;

//=============================================================================
//  文字列を"(ダブルコーテーション)で囲んだ文字列を作成する関数
//=============================================================================
function TplArchieverLZH.AddQuotedStr(Str: String): String;
begin
  Result := SysUtils.AnsiQuotedStr(Str, '"');
end;

end.