皆さんよくご存じの「UNLHA32」をExcelから扱う組み込みツールを用意して見ました。

まずは、サンプルを見てみましょう。

シート上にファイル名を登録しておき、「ファイル圧縮」のボタンで圧縮が行なえます。


(画像をクリックすると、このページのサンプルがダウンロードできます)
※本機能には「UNLHA32」コンポーネント(フリーソフト)」が必要です。

1行目(Excelの2行目)には、圧縮後のファイル名を指定します。
フォルダを指定しなければ、このワークブックがあるフォルダに作成されます。拡張子は「LZH」か「EXE」として下さい。「EXE」の場合は自動解凍書庫として圧縮されます。
2行目(Excelの3行目)以降には、圧縮する対象となる元のファイル名をフルパスで指定します。「圧縮対象ファイルの参照登録」をクリックすれば、ファイルをドラッグして登録できます。複数ファイルが同時に登録できます。
圧縮対象ファイルの指定の後で「ファイル圧縮」をクリックして下さい。

圧縮対象ファイルの指定で「フォルダ」を指定することができます。 「圧縮対象ファイルの参照登録」ボタンからはファイルしか指定できませんが、直接C3セルにフォルダを登録させると、その配下にある全てのサブフォルダ、ファイルがフォルダ構成のまま圧縮の対象になります。本モジュールでは「フォルダ」を指定する場合は複数のフォルダを同時に指定することはできません。

ダウンロードしたファイルを解凍すると、上記のサンプルのExcelワークブックと「clsArchiveByUNLHA32.cls」が作成されます。 この「clsArchiveByUNLHA32.cls」は既にExcelワークブックには組み込まれています。
ファイル圧縮の最小限の引数は、圧縮後のファイル名と圧縮対象となるファイル名(フルパスで複数の場合は配列で渡す)、エラーメッセージの3つです。戻り値がTrueなら正常終了です。サンプルを参考にして組み込んで下さい。以下がサンプル(Sheet1.cls)のコードです。

'***************************************************************************************************
'   LHAファイル圧縮                                             Sheet1(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 06/05/06(1.0.0)新規作成
' 17/09/24(2.0.0)クラス化移行(modArchiveByUNLHA32⇒clsArchiveByUNLHA32)
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "LHAファイル圧縮"

'***************************************************************************************************
'* 処理名　：CommandButton1_Click
'* 機能　　：｢ファイル圧縮｣ボタンクリックイベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2006年05月06日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub CommandButton1_Click()
    '-----------------------------------------------------------------------------------------------
    Dim strToFile As String                                         ' 圧縮後ファイル名
    Dim vntFromFile As Variant                                      ' 圧縮対象ファイル名
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngRowMax As Long                                           ' 行INDEX上限
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim strErrMSG As String                                         ' エラーメッセージ
    With ThisWorkbook.Worksheets(1)
        ' Excel認知の最終行判定→GYOMAX
        lngRowMax = .Cells(.Rows.Count, 3).End(xlUp).Row
        ' 圧縮ファイルのファイル名
        strToFile = Trim(.Cells(2, 3).Value)
        lngRow = 3
        ' 複数行登録か
        If lngRowMax > 3 Then
            ' テーブル変数の初期化
            lngIx = -1
            ReDim vntFromFile(0)
            ' 圧縮元ファイル名をテーブル変数に格納
            Do While lngRow <= lngRowMax
                If Trim(.Cells(lngRow, 3).Value) <> "" Then
                    lngIx = lngIx + 1
                    ReDim Preserve vntFromFile(lngIx)
                    vntFromFile(lngIx) = Trim(.Cells(lngRow, 3).Value)
                End If
                lngRow = lngRow + 1
            Loop
        Else
            ' 単一ファイル(フォルダ)の場合は配列化しない
            vntFromFile = Trim(.Cells(3, 3).Value)
        End If
    End With
    ' LHAファイル圧縮機能の呼出し
    With New clsArchiveByUNLHA32
        ' 処理成功か
        If .ArchiveByUNLHA32(strToFile, vntFromFile, strErrMSG) Then
            MsgBox "ファイル圧縮が完了しました。" & vbCr & _
                "圧縮ファイルは、" & strToFile & " です。", vbInformation, g_cnsTitle
        Else
            MsgBox strErrMSG, vbExclamation, g_cnsTitle
        End If
    End With
    ThisWorkbook.Saved = True
End Sub

'***************************************************************************************************
'* 処理名　：CommandButton2_Click
'* 機能　　：｢圧縮対象ファイルの参照登録｣ボタンクリックイベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2006年05月06日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub CommandButton2_Click()
    '-----------------------------------------------------------------------------------------------
    ' ユーザーフォーム起動
    g_lngTblEntFileMax = -1
    UF_EntFiles.Show
    Unload UF_EntFiles
    If g_lngTblEntFileMax < 0 Then Exit Sub
    '-----------------------------------------------------------------------------------------------
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngIx As Long                                               ' テーブルINDEX
    With ThisWorkbook.Worksheets(1)
        lngRow = .Range("$C$" & .Rows.Count).End(xlUp).Row
        ' 圧縮対象ファイルが登録されている場合は一旦削除
        If lngRow >= 3 Then
            .Range(.Cells(3, 3), .Cells(lngRow, 3)).ClearContents
        End If
        lngRow = 2
        ' 今回ドラッグされたファイルを登録
        Do While lngIx <= g_lngTblEntFileMax
            lngRow = lngRow + 1
            .Cells(lngRow, 3).Value = g_tblEntFile(lngIx)
            ' 次へ
            lngIx = lngIx + 1
        Loop
    End With
    ThisWorkbook.Saved = True
End Sub

'------------------------------------------<< End of Source >>--------------------------------------

以下が組み込み用クラス「clsArchiveByUNLHA32.cls」のコードです。

先に説明した通りですが、こちらはほとんど改変することなく他のプロジェクトにインポートして利用できると思います。 ただ、引数等の機能詳細は説明していませんから、勉強としてコードの中身がどのような動作になるのかは理解された方が良いと思います。

'***************************************************************************************************
'   LHAファイル圧縮機能(UNLHA32.dll必須)                        clsArchiveByUNLHA32(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 06/05/06(1.0.0)新規作成
' 17/09/24(2.0.0)クラス化移行(modArchiveByUNLHA32⇒clsArchiveByUNLHA32)
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsLZH As String = ".lzh"
Private Const g_cnsEXE As String = ".exe"
Private Const MAX_PATH As Long = 260                                ' パス名文字列長上限
'---------------------------------------------------------------------------------------------------
' UNLHA32のバージョンを取得する(UNLHA32)
Private Declare Function UnlhaGetVersion Lib "UNLHA32.dll" () As Integer
' UNLHA32の動作状態を確認する(UNLHA32)
Private Declare Function UnlhaGetRunning Lib "UNLHA32.dll" () As Boolean
' LHA圧縮を操作するAPI(UNLHA32)
Private Declare Function Unlha Lib "UNLHA32.dll" _
    (ByVal lhWnd As Long, _
     ByVal szCmdLine As String, _
     ByVal szOutPut As String, _
     ByVal wSize As Long) As Long
' ウィンドウハンドルを返す
Private Declare Function FindWindow Lib "USER32.dll" Alias "FindWindowA" _
    (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
'---------------------------------------------------------------------------------------------------
Private g_strWindowCaption As String                                ' 親ウィンドウタイトル

'***************************************************************************************************
'   ■■■ クラス初期化 ■■■
'***************************************************************************************************
'* 処理名　：Class_Initialize
'* 機能　　：クラス初期化
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub Class_Initialize()
    '-----------------------------------------------------------------------------------------------
    ' ウィンドウ名を現在のExcel.Applicationタイトルに設定
    g_strWindowCaption = Application.Caption
End Sub

'***************************************************************************************************
'   ■■■ 外部からの呼び出しプロシージャ(Friend) ■■■
'***************************************************************************************************
'* 処理名　：ArchiveByUNLHA32
'* 機能　　：LHAファイル圧縮機能(UNLHA32.dll必須)
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = 圧縮後のファイル名(String)          ※Ref参照
'* 　　　　　Arg2 = 圧縮対象のファイル名(Variant)       ※複数の場合は配列をセットする
'* 　　　　　Arg3 = エラーメッセージ(Atring)            ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2006年05月06日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Friend Function ArchiveByUNLHA32(ByRef strTarget As String, _
                                 ByRef vntSource As Variant, _
                                 ByRef strErrMSG As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim strCommand As String                                        ' コマンドライン
    ArchiveByUNLHA32 = False
    '-----------------------------------------------------------------------------------------------
    ' 圧縮指定値及び環境チェック(+コマンドライン編集)
    If Not FP_CheckArchive(strTarget, _
                           vntSource, _
                           strCommand, _
                           strErrMSG) Then
        Exit Function
    End If
    '-----------------------------------------------------------------------------------------------
    ' UNLHA32コマンド発行
    ArchiveByUNLHA32 = LetCommandByUNLHA32(strCommand, strErrMSG)
    On Error GoTo 0
End Function

'***************************************************************************************************
'* 処理名　：LetCommandByUNLHA32
'* 機能　　：UNLHA32コマンド発行(任意コマンドライン)
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = コマンドライン(String)
'* 　　　　　Arg2 = エラーメッセージ(Atring)            ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Friend Function LetCommandByUNLHA32(ByVal strCommand As String, _
                                    ByRef strErrMSG As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim hWnd As Long                                                ' ウィンドウハンドル値
    Dim strMSG_Base As String                                       ' メッセージベース
    Dim strBuffer As String                                         ' Work
    LetCommandByUNLHA32 = False
    On Error GoTo LetCommandByUNLHA32_ERROR
    '-----------------------------------------------------------------------------------------------
    strMSG_Base = "圧縮コンポーネント｢UNLHA32｣がインストールされていません。"
    ' UNLHA32.dllの存在確認(バージョン取得試行)
    Call UnlhaGetVersion
    '-----------------------------------------------------------------------------------------------
    strMSG_Base = "圧縮コンポーネント｢UNLHA32｣が他で動作中です。"
    ' UNLHA32.dllの動作状況確認
    If UnlhaGetRunning Then
        strErrMSG = strMSG_Base
        Exit Function
    End If
    DoEvents                    ' ←これがないと動作不安定になるようです？
    '-----------------------------------------------------------------------------------------------
    strMSG_Base = "｢UNLHA32｣処理に失敗しました。"
    ' ウィンドウハンドルを取得
    hWnd = FP_GetWindowHwnd
    strBuffer = String(256, Chr(0))
    ' コマンドラインに従ってUNLHAを操作
    If Unlha(hWnd, strCommand, strBuffer, Len(strBuffer)) = 0& Then
        LetCommandByUNLHA32 = True
    Else
        strErrMSG = Left(strBuffer, InStr(1, strBuffer, Chr(0)) - 1)
    End If
    On Error GoTo 0
    Exit Function

'===================================================================================================
LetCommandByUNLHA32_ERROR:
    strErrMSG = strMSG_Base & vbCrLf & Err.Description
    On Error GoTo 0
End Function

'***************************************************************************************************
'   ■■■ サブ処理(Private) ■■■
'***************************************************************************************************
'* 処理名　：FP_CheckArchive
'* 機能　　：圧縮指定値及び環境チェック(+コマンドライン編集)
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = 圧縮後のファイル名(String)          ※Ref参照
'* 　　　　　Arg2 = 圧縮対象のファイル名(Variant)       ※複数の場合は配列をセットする
'* 　　　　　Arg3 = 編集したコマンドライン(String)      ※Ref参照
'* 　　　　　Arg4 = エラーメッセージ(String)            ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2006年05月06日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_CheckArchive(ByRef strTarget As String, _
                                 ByRef vntSource As Variant, _
                                 ByRef strCommand As String, _
                                 ByRef strErrMSG As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim objFSO As FileSystemObject                                  ' FileSystemObject
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim strPathName As String                                       ' フォルダ名(Work)
    Dim strFilename As String                                       ' ファイル名(Work)
    Dim strExtL As String                                           ' 拡張子(小文字)
    FP_CheckArchive = False
    Set objFSO = New FileSystemObject
    '-----------------------------------------------------------------------------------------------
    ' 圧縮後ファイル名チェック
    strFilename = Trim(strTarget)
    ' ブランクか
    If strFilename = "" Then
        strErrMSG = "出力ファイルが指定されていません。"
        Set objFSO = Nothing
        Exit Function
    End If
    ' フルパスでなければ本ブックのフォルダを指定
    If ((Left$(strFilename, 2) <> "\\") And (Mid$(strFilename, 2, 2) <> ":\")) Then
        strPathName = ThisWorkbook.Path
        strTarget = objFSO.BuildPath(strPathName, strFilename)
    Else
        strTarget = strFilename
        strFilename = objFSO.GetFileName(strTarget)
        strPathName = Left$(strTarget, Len(strTarget) - Len(strFilename) - 1)
    End If
    ' フォルダが実在するか
    If Not objFSO.FolderExists(strPathName) Then
        strErrMSG = "出力ファイルのフィルダが実在しません。" & vbCrLf & strPathName
        Set objFSO = Nothing
        Exit Function
    End If
    strExtL = LCase(Right(strTarget, 4))                            ' 拡張子
    ' 拡張子の判定(未指定の場合は強制的に付加)
    If ((strExtL <> g_cnsLZH) And (strExtL <> g_cnsEXE)) Then
        strTarget = strTarget & g_cnsLZH
        strFilename = strFilename & g_cnsLZH
    End If
    '-----------------------------------------------------------------------------------------------
    ' UNLHAのコマンドライン編集を開始
    strCommand = "a "
    ' 自動解凍書庫指定か⇒スイッチ追加
    If strExtL = g_cnsEXE Then
        strCommand = strCommand & "-gw4 "
    End If
    strCommand = strCommand & """" & strTarget & """"
    '-----------------------------------------------------------------------------------------------
    ' 圧縮対象ファイル名チェック
    If IsArray(vntSource) Then
        lngIx = 0
        ' 複数ファイル指定(複数フォルダには対応していない)
        Do While lngIx <= UBound(vntSource)
            strFilename = Trim(vntSource(lngIx))
            ' 実在確認
            If Not objFSO.FileExists(strFilename) Then
                strErrMSG = "入力ファイルが実在しません。" & vbCrLf & strFilename
                Set objFSO = Nothing
                Exit Function
            Else
                strCommand = strCommand & " """ & strFilename & """"
            End If
            ' 次のファイルへ
            lngIx = lngIx + 1
        Loop
    Else
        strFilename = Trim(vntSource)
        ' 無指定か
        If strFilename = "" Then
            strErrMSG = "入力ファイルが指定されていません。"
            Set objFSO = Nothing
            Exit Function
        ElseIf objFSO.FolderExists(strFilename) Then
            ' フォルダ指定の場合は配下全てを格納
            strCommand = strCommand & " -d1 """ & objFSO.GetParentFolderName(strFilename) & "\"" " & _
                objFSO.GetFileName(strFilename)
        ElseIf objFSO.FileExists(strFilename) Then
            ' ファイル指定
            strCommand = strCommand & " """ & strFilename & """"
        Else
            ' 指定不正
            strErrMSG = "入力ファイルが実在しません。" & vbCrLf & strFilename
            Set objFSO = Nothing
            Exit Function
        End If
    End If
    '-----------------------------------------------------------------------------------------------
    ' 圧縮先ファイル名が既に存在する時は一旦削除
    If objFSO.FileExists(strTarget) Then
        On Error Resume Next
        objFSO.DeleteFile strTarget, True
        ' エラー判定
        If Err.Number <> 0 Then
            strErrMSG = "出力ファイルの事前削除に失敗しました。" & vbCrLf & Err.Description
            On Error GoTo 0
            Set objFSO = Nothing
            Exit Function
        End If
        On Error GoTo 0
    End If
    '-----------------------------------------------------------------------------------------------
    Set objFSO = Nothing
    FP_CheckArchive = True
End Function

'***************************************************************************************************
'* 処理名　：FP_GetWindowHwnd
'* 機能　　：ウィンドウハンドル取得
'---------------------------------------------------------------------------------------------------
'* 返り値　：ウィンドウハンドル(Long)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2006年05月06日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_GetWindowHwnd() As Long
    '-----------------------------------------------------------------------------------------------
    ' Excelウィンドウか
    Select Case g_strWindowCaption
        Case "", Application.Caption
            ' Excelウィンドウと判断
            FP_GetWindowHwnd = Application.hWnd
        Case Else
            ' ユーザーフォームと判断
            On Error Resume Next
            FP_GetWindowHwnd = FindWindow("ThunderDFrame", g_strWindowCaption)
            ' エラー判定⇒Excelウィンドウと判断
            If Err.Number <> 0 Then
                FP_GetWindowHwnd = Application.hWnd
            End If
            On Error GoTo 0
    End Select
End Function

'***************************************************************************************************
'   ■■■ プロパティ ■■■
'***************************************************************************************************
'   親ウィンドウタイトル(String)
'---------------------------------------------------------------------------------------------------
Friend Property Let prpWindowCaption(ByVal Value As String)
    '-----------------------------------------------------------------------------------------------
    g_strWindowCaption = Value
End Property

'------------------------------------------<< End of Source >>--------------------------------------

ここでダウンロードする内容には、「UNLHA32.dll」本体及び関連ドキュメントは含まれていません。

なお、「圧縮対象ファイルの参照登録」で表示されるユーザーフォームでは、フォルダウィンドウからドラッグ＆ドロップで複数のファイルを登録できるようにしてありますが、 この機能については本ページの主目的から外れますのでソースコードの掲示は行なっておりません。 関心がある方は下記サンプルをダウンロードして内容をご覧下さい。

←ArchiveByUNLHA32.zip       (62KB)