unit Archive;

// LZH/ZIP形式の圧縮ファイルを解凍 (要:UnLha32.dll, UnZip32.dll)

interface

uses
  Windows, SysUtils, Classes, Dialogs;

    procedure Init_Archive;
    procedure Term_Archive;
    function  lzh_extract( srcFile, desFile: string ): boolean;
    function  zip_extract( srcFile, desFile: string ): boolean;

var
    CanUnLha, CanUnZip: boolean;

implementation

type
  TDllPrnt = function(Buffer: PChar; Size: ULONG): integer; stdcall;
  TDllPassword = function(P: PChar; N: Integer; M, Name: PChar): integer; stdcall;
  TDllService = function (CurFile: PChar; Size: ULONG): integer; stdcall;
  TDllSnd = procedure; stdcall;
  TDllReplace = function(FileName: PChar): integer; stdcall;
  TDllMessage = procedure (UnCompSize: ULONG; CompSize: ULONG; Factor: UINT;
    Month: UINT; Day: UINT; Year: UINT; Hour: UINT; Minute: UINT;
    C: Char; FileName: PChar; MethBuf: PChar; CRC: ULONG; Crypt: Char); stdcall;

  PUserFunctions = ^TUserFunctions;
  USERFUNCTIONS = record
    Print                  : TDllPrnt;
    Sound                  : TDllSnd;
    Replace                : TDllReplace;
    Password               : TDllPassword;
    SendApplicationMessage : TDllMessage;
    ServCallBk             : TDllService;
    TotalSizeComp          : ULONG;
    TotalSize              : ULONG;
    CompFactor             : Integer;
    NumMembers             : UINT;
    cchComment             : UINT;
  end;
  TUserFunctions = USERFUNCTIONS;

  PDCL = ^TDCL;
  DCL = record
    ExtractOnlyNewer  : Integer; { true if you are to extract only newer }
    SpaceToUnderscore : Integer; { true if convert space to underscore }
    PromptToOverwrite : Integer; { true if prompt to overwrite is wanted }
    fQuiet            : Integer; { quiet flag. 1 = few messages, 2 = no messages, 0 = all messages }
    nCFlag            : Integer; { write to stdout if true }
    nTFlag            : Integer; { test zip file }
    nVFlag            : Integer; { verbose listing }
    nUFlag            : Integer; { "update" (extract only newer/new files) }
    nZFlag            : Integer; { display zip file comment }
    nDFlag            : Integer; { all args are files/dir to be extracted }
    nOFlag            : Integer; { true if you are to always over-write files, false if not }
    nAFlag            : Integer; { do end-of-line translation }
    nZIFlag           : Integer; { get zip info if true }
    C_flag            : Integer; { be case insensitive if TRUE }
    fPrivilege        : Integer; { 1 => restore Acl's, 2 => Use privileges }
    lpszZipFN         : PChar;   { zip file name }
    lpszExtractDir    : PChar;   { Directory to extract to. NULL for the current directory }
  end ;
  TDCL = DCL;

var
    UnLha32Dll, UnZip32Dll: THandle;
    _Unlha: function(_hwnd:HWND; szCmdLine,szOutput:PChar; wSize:dword):
                        integer stdcall;
    _Wiz_SingleEntryUnzip: function(_hwnd:HWND; ifnv:PPChar; xfnc:Integer;
        xfnv:PPChar; var Options:TDCL; var UserFunc:TUserFunctions):
                        integer; stdcall;

//======================================================================
//  機能：解凍の初期処理
//======================================================================
procedure Init_Archive;
begin
    // UNLHA32.DLLのライブラリロード
    UnLha32Dll := LoadLibrary( 'UNLHA32.DLL' );
    @_Unlha    := Nil;
    if UnLha32Dll<>0 then begin     {UNLHA32.DLLが存在する}
        @_Unlha := GetProcAddress( UnLha32Dll,'Unlha' );
    end;
    CanUnLha := @_Unlha<>Nil;

    // UNZIP32.DLLのライブラリロード
    UnZip32Dll := LoadLibrary( 'UNZIP32.DLL' );
    @_Wiz_SingleEntryUnzip := Nil;
    if UnZip32Dll<>0 then begin     {UNZIP32.DLLが存在する}
        @_Wiz_SingleEntryUnzip :=
            GetProcAddress( UnZip32Dll,'Wiz_SingleEntryUnzip' );
    end;
    CanUnZip := @_Wiz_SingleEntryUnzip<>Nil;
end;


//======================================================================
//  機能：解凍の終了処理
//======================================================================
procedure Term_Archive;
begin
    if UnLha32Dll<>0 then FreeLibrary(UnLha32Dll);
    if UnZip32Dll<>0 then FreeLibrary(UnZip32Dll);
end;


//======================================================================
//  機能：LZH形式の圧縮ファイルを解凍
//======================================================================
function lzh_extract( srcFile, desFile: string ): boolean;
var
        CmdLine, Output: string;
        iRet: Integer;
begin
    if CanUnLha=FALSE then
        iret := -1
    else begin
        SetLength( Output,255 );    {解凍結果を返す為のバッファ}
                                    {(未使用なのでサイズは適当)}
//      CmdLine := format( 'e "%s" "%s"',[srcFile,desFile] );       {Path無効}
        CmdLine := format( 'x -jf0 "%s" "%s"',[srcFile,desFile] );  {Path有効}
        iRet := _Unlha( 0, PChar(Cmdline), PChar(Output), Length(Output) );
    end;
    Result := (iRet=0);
end;


//----------------------------------------------------------------------
//  機能:UnZip32.dllの為の関数群
//----------------------------------------------------------------------
function DummyPrint(Buffer: PChar; Size: LongWord): Integer; stdcall;
begin
    if Buffer<>nil then begin
        if StrPos(Buffer, 'error')<>Nil then
            ShowMessage('UnZip32.dllでエラーが発生');
    end;
    Result := Size;
end;

//----------------------------------------------------------------------
function DllReplace(FileName: PChar): integer; stdcall;
begin
    Result := 1;
end;

//----------------------------------------------------------------------
function DummyPassword(P: PChar; N: Integer; M, Name: PChar): Integer; stdcall;
begin
    Result := 1;
end;

//----------------------------------------------------------------------
function DllPassword(P: PChar; N: Integer; M, Name: PChar): integer; stdcall;
begin
    Result := 1;
end;

//----------------------------------------------------------------------
procedure DllMessage( UnCompSize: ULONG; CompSize: ULONG; Factor: UINT;
    Month: UINT; Day: UINT; Year: UINT; Hour: UINT; Minute: UINT;
    C: Char; FileName: PChar; MethBuf: PChar; CRC: ULONG; Crypt: Char); stdcall;
begin
    Exit;
end;

//----------------------------------------------------------------------
function DllService(CurFile: PChar; Size: ULONG): integer; stdcall;
begin
    Result := 0;
end;


//----------------------------------------------------------------------
procedure Set_UserFunctions(var Z:TUserFunctions);
begin
    { prepare TUserFunctions structure }
    with Z do begin
        @Print                  := @DummyPrint;
        @Sound                  := nil;
        @Replace                := @DllReplace;
        @Password               := @DllPassword;
        @SendApplicationMessage := @DllMessage;
        @ServCallBk             := @DllService;
    end;
end;


//======================================================================
//  機能：ZIP形式の圧縮ファイルを解凍
//======================================================================
function zip_extract(srcFile, desFile: string): boolean;
var
        UF: TUserFunctions;
        Opt: TDCL;
        rc: integer;
begin
    if CanUnZip=FALSE then
        rc := -1
    else begin
        Set_UserFunctions(UF);

        { set unzip operation options }
        ZeroMemory( @Opt, Sizeof(Opt) );
//      Opt.nDFlag := 0;    // path無しで展開
        Opt.nDFlag := 1;    // path付きで展開
        Opt.fPrivilege := 1;
        Opt.lpszZipFN      := PChar(srcFile);
        Opt.lpszExtractDir := PChar(desFile);
        Opt.nTFlag := 0;

        { extract }
        rc := _Wiz_SingleEntryUnzip(
            0,      { number of file names being passed }
            nil,    { file names to be unarchived }
            0,      { number of "file names to be excluded from processing" being  passed }
            nil,    { file names to be excluded from the unarchiving process }
            Opt,    { pointer to a structure with the flags for setting the  various options }
            UF      { pointer to a structure that contains pointers to user functions }
        );
    end;
    Result := (rc=1);
end;

end.

(上記コードをArchive.pasとして保存する)


<< 使用例 >>

uses Archive;

procedure TForm1.Button1Click(Sender: TObject);
var
        kakucho: string;
        result: boolean;
begin
    Init_Archive();

    result := FALSE;
    kakucho := LowerCase( ExtractFileExt(ファイル名) );
    if CanUnLha and (kakucho='.lzh') then begin
        result := lzh_extract( ファイル名,展開先フォルダー );
    end;
    if CanUnZip and (kakucho='.zip') then begin
        result := zip_extract( ファイル名,展開先フォルダー );
    end;
    if result=FALSE then
        ShowMessage( '指定ファイルを解凍出来ません。' );

    Term_Archive();
end;


<< バグ情報 >>
・セキュリティ情報を含むZIP形式をNTFS形式のドライブに解凍すると、セキュリティ
  情報のユーザー名が正しく作成されません。

<< 修正履歴 >>
・LZH形式を解凍時、解凍先パス名に空白が含まれていると処理が失敗するので
  修正 (2009/12/02)