ダウンロード(ファイル圧縮：7-ZIP32、7-ZIP64利用)

ZIP書庫の圧縮・解凍なら、7-ZIP32.DLLでしょう。

ZIP書庫の圧縮・解凍ができます ZIP書庫で「UNLHA32.dll」のように圧縮も解凍もできるコンポーネントとしては「7-ZIP32.DLL」を利用することになるのでしょう。「7-ZIP32.DLL」は本来は「7z書庫」の圧縮・解凍に向けて開発されたコンポーネントだったようですが、同時に「ZIP書庫」にも対応していたため、現在ではWindowsの標準ともなっている「ZIP書庫」の方がメインで利用で用いられていると思います。
「7-ZIP32.DLL」を利用する一般的な圧縮および解凍のプロシージャを用意して見ました。
Officeが64ビット版の場合は、「7-ZIP64.DLL」で利用可能です。

「7-ZIP32.DLL」やその他の圧縮・解凍コンポーネントのダウンロードおよび機能詳細については「統合アーカイバプロジェクト」をご覧下さい。

「7-ZIP32.DLL」等の圧縮関連DLLは、Windowsのシステムフォルダにある状態にして下さい。

通常のMicrosoft Officeは32ビットアプリケーションですから、これらの32ビット版圧縮・解凍コンポーネントが扱えますが、 Windowsが64ビット版の場合は配置されているWindowsシステムフォルダは「C:\Windows\SysWOW64」となります。「C:\Windows\System32」というフォルダも存在しますが、ここは名前から類推されるものをは異なり64ビット版のコンポーネント等が配置される場所です。 64ビット版のMicrosoft Officeの場合は「C:\Windows\System32」に「7-ZIP64.DLL」を配置させて下さい。
また、「GetSystemDirectory」などの関数(API)でシステムフォルダのパスを調べると、 32ビットアプリケーションであっても「C:\Windows\System32」を返しますが、このフォルダに対して「7-ZIP32.DLL」の存在をDirやFSO.FileExistsで問い合わせると、実際には「C:\Windows\SysWOW64」に配置されているのに「True」が返ってくるのが、 64ビット版Windows上で32ビットアプリケーションが正しく動作できるようになっている仕組みのひとつです。

では、サンプルで動作確認してみます。

シートは2つあり「ZIP圧縮サンプル」「ZIP解凍サンプル」としています。

(この画像をクリックすると、ダウンロードができます。)

圧縮の場合はこの画面で圧縮する対象のフォルダ又はファイルとZIP圧縮ファイル名およびオプションを指定して処理開始ボタンで実行されます。対象フォルダ／ファイルは、このサンプルではシートデザインの都合上でファイルの場合は最大10ファイルまで指定できますが、フォルダの場合は1フォルダのみとなっています。
右上の「圧縮対象ファイルの参照登録」ボタンをクリックするとユーザーフォームが表示され、そのユーザーフォームにはフォルダウィンドウから複数のファイルを一度にドラッグ＆ドロップで登録できるようになっています。
「ZIP圧縮ファイル名」の方はデフォルトで「Sample.zip」となっており、このようにフルパスでないファイル名の場合は、本ワークブックのフォルダに圧縮ファイルが作成されます。

ファイル解凍操作

解凍の場合はZIP圧縮ファイル名と解凍先フォルダおよびオプションを指定して処理開始ボタンで実行されます。

サンプルのコードです。

「圧縮処理開始」または「解凍処理開始」のボタンのクリックイベントの処理は各シートモジュールに記載されています。
まず、こちらが「ZIP圧縮サンプル」シートのコードです。


'***************************************************************************************************
'   ZIPファイル圧縮／解凍機能(7-ZIP32.DLL必須)                  Sheet1(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 12/03/04(1.0.0)新規作成
' 17/09/24(2.0.0)クラス化移行(modArchiveBySevenZip32⇒clsArchiveBySevenZip32)
' 17/09/30(2.0.0)圧縮対象ファイルの複数指定機能対応、参照ボタンの追加
' 20/03/04(2.0.1)ダイアログを表示をmodFolderPicker1からmodFolderPicker2に変更
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "ZIP圧縮サンプル"

'***************************************************************************************************
'   ■■■ ワークシートイベント ■■■
'***************************************************************************************************
'* 処理名　：CommandButton1_Click
'* 機能　　：｢圧縮処理開始｣ボタンクリックイベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2012年03月04日
'* 作成者　：井上　治
'* 更新日　：2017年09月30日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub CommandButton1_Click()
    '-----------------------------------------------------------------------------------------------
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngRowMax As Long                                           ' 行INDEX上限
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim vntFromFile As Variant                                      ' 圧縮対象ファイル名
    Dim strDstPath As String                                        ' 圧縮後ファイル名
    Dim strPass As String                                           ' パスワード
    Dim blnAppend As Boolean                                        ' 追加判定
    Dim strErrMSG As String                                         ' エラーメッセージ
    '-----------------------------------------------------------------------------------------------
    ' Excel認知の最終行判定→GYOMAX
    lngRowMax = Cells(12, 2).End(xlUp).Row
    lngRow = 2
    ' 対象フォルダ／ファイル名
    If lngRowMax > 2 Then
        ' テーブル変数の初期化
        lngIx = -1
        ReDim vntFromFile(0)
        ' 圧縮元ファイル名をテーブル変数に格納
        Do While lngRow <= lngRowMax
            If Trim(Cells(lngRow, 2).Value) <> "" Then
                lngIx = lngIx + 1
                ReDim Preserve vntFromFile(lngIx)
                vntFromFile(lngIx) = Trim(Cells(lngRow, 2).Value)
            End If
            lngRow = lngRow + 1
        Loop
    Else
        ' 単一ファイル(フォルダ)の場合は配列化しない
        vntFromFile = Trim(Cells(2, 2).Value)
    End If
    ' ZIP圧縮ファイル名
    strDstPath = Trim(Cells(13, 2).Value)
    ' 追加／置換(オプション)
    blnAppend = Cells(15, 2).Value = "追加"
    ' パスワード(オプション)
    strPass = Trim(Cells(17, 2).Value)
    '-----------------------------------------------------------------------------------------------
    ' ZIP圧縮処理を呼び出す
    With New clsArchiveBySevenZip32
        If Not .ArchiveBySevenZip32(vntFromFile, _
                                    strDstPath, _
                                    strErrMSG, _
                                    blnAppend, _
                                    strPass) Then
            MsgBox strErrMSG, vbCritical, g_cnsTitle
        End If
    End With
End Sub

'***************************************************************************************************
'* 処理名　：CommandButton2_Click
'* 機能　　：｢圧縮対象ファイルの参照登録｣ボタンクリックイベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月30日
'* 作成者　：井上　治
'* 更新日　：2017年09月30日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：本サンプルでは最大10件
'***************************************************************************************************
Private Sub CommandButton2_Click()
    '-----------------------------------------------------------------------------------------------
    ' ユーザーフォーム起動
    g_lngTblEntFileMax = -1
    UF_EntFiles.Show
    Unload UF_EntFiles
    If g_lngTblEntFileMax < 0 Then Exit Sub
    ' 10件超の場合は10件に修正
    If g_lngTblEntFileMax > 9 Then g_lngTblEntFileMax = 9
    '-----------------------------------------------------------------------------------------------
    Dim lngRow As Long                                              ' 行INDEX
    Dim lngIx As Long                                               ' テーブルINDEX
    With ThisWorkbook.Worksheets(1)
        .Range("$B$2:$I$11").ClearContents
        lngRow = 1
        ' 今回ドラッグされたファイルを登録
        Do While lngIx <= g_lngTblEntFileMax
            lngRow = lngRow + 1
            .Cells(lngRow, 2).Value = g_tblEntFile(lngIx)
            ' 次へ
            lngIx = lngIx + 1
        Loop
    End With
    ThisWorkbook.Saved = True
End Sub

'***************************************************************************************************
'* 処理名　：CommandButton3_Click
'* 機能　　：｢参照｣ボタンクリックイベント(ZIP圧縮ファイル名)
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月30日
'* 作成者　：井上　治
'* 更新日　：2020年03月04日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub CommandButton3_Click()
    '-----------------------------------------------------------------------------------------------
    Dim strFilename As String                                       ' ファイル名
    ' 「名前を付けて保存」ダイアログを表示(modFolderPicker2)
    strFilename = modFolderPicker2.SaveDialog(g_cnsTitle, False, ThisWorkbook.Path, 3)
    ' ファイル名の指定を受けたらセルに格納
    If strFilename <> "" Then
        Cells(13, 2).Value = strFilename
    End If
    ThisWorkbook.Saved = True
End Sub

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

シート画面の下の2項目はオプションです。「何(フォルダ又はファイル)を圧縮するのか」と「圧縮されたファイル名」を指定すれば良いようにしてあります。オプションには「追加／置換」のモードと「パスワード」が用意してあります。「追加／置換」のモードは「追加」にした場合は作成済みのZIP書庫ファイルに追加されるようになっています。
ファイル参照系のモジュールやフォームも本プロジェクトに持ち込んでいますが、このページでの説明範囲ではないのでコードの紹介は行なっていません。関心がある方はソースコードをご覧下さい。

続いて、こちらが「ZIP解凍サンプル」シートのコードです。


'***************************************************************************************************
'   ZIPファイル圧縮／解凍機能(7-ZIP32.DLL必須)                  Sheet2(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 12/03/04(1.0.0)新規作成
' 17/09/24(2.0.0)クラス化移行(modArchiveBySevenZip32⇒clsArchiveBySevenZip32)
' 20/03/04(2.0.1)ダイアログを表示をmodFolderPicker1からmodFolderPicker2に変更
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsTitle As String = "ZIP解凍サンプル"

'***************************************************************************************************
'   ■■■ ワークシートイベント ■■■
'***************************************************************************************************
'* 処理名　：CommandButton1_Click
'* 機能　　：｢解凍処理開始｣ボタンクリックイベント
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2012年03月04日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub CommandButton1_Click()
    '-----------------------------------------------------------------------------------------------
    Dim strZipFile As String                                        ' ZIP圧縮ファイル
    Dim strDstPath As String                                        ' 解凍先フォルダ名
    Dim strPass As String                                           ' パスワード
    Dim blnOverWrite As Boolean                                     ' 上書き指定
    Dim strErrMSG As String                                         ' エラーメッセージ
    '-----------------------------------------------------------------------------------------------
    ' ZIP圧縮ファイル名
    strZipFile = Trim(Cells(2, 2).Value)
    ' 解凍先フォルダ名
    strDstPath = Trim(Cells(4, 2).Value)
    ' 上書き確認(オプション)
    blnOverWrite = Cells(6, 2).Value = "強制上書き"
    ' パスワード(オプション)
    strPass = Trim(Cells(8, 2).Value)
    '-----------------------------------------------------------------------------------------------
    ' ZIP解凍処理を呼び出す
    With New clsArchiveBySevenZip32
        If Not .ExtractBySevenZip32(strZipFile, _
                                    strDstPath, _
                                    strErrMSG, _
                                    blnOverWrite, _
                                    strPass) Then
            MsgBox strErrMSG, vbCritical, g_cnsTitle
        End If
    End With
End Sub

'***************************************************************************************************
'* 処理名　：CommandButton2_Click
'* 機能　　：｢参照｣ボタンクリックイベント(ZIP圧縮ファイル名)
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月30日
'* 作成者　：井上　治
'* 更新日　：2020年03月04日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub CommandButton2_Click()
    '-----------------------------------------------------------------------------------------------
    Dim strFilename As String                                       ' ファイル名
    ' 「ファイルを開く」ダイアログを表示(modFolderPicker2)
    strFilename = modFolderPicker2.OpenDialog(g_cnsTitle, , False, ThisWorkbook.Path, 3)
    ' ファイル名の指定を受けたらセルに格納
    If strFilename <> "" Then
        Cells(2, 2).Value = strFilename
    End If
    ThisWorkbook.Saved = True
End Sub

'***************************************************************************************************
'* 処理名　：CommandButton3_Click
'* 機能　　：｢参照｣ボタンクリックイベント(解凍先フォルダ名)
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月30日
'* 作成者　：井上　治
'* 更新日　：2020年03月04日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub CommandButton3_Click()
    '-----------------------------------------------------------------------------------------------
    Dim strPathname As String                                       ' ファイル名
    ' 「フォルダの参照」ダイアログを表示(modFolderPicker2)
    strPathname = modFolderPicker2.FolderDialog(g_cnsTitle, False, ThisWorkbook.Path, 3)
    ' フォルダ名の指定を受けたらセルに格納
    If strPathname <> "" Then
        Cells(4, 2).Value = strPathname
    End If
    ThisWorkbook.Saved = True
End Sub

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

解凍の場合は、解凍先に同一ファイル名がすでにある場合の動作を制御します。「上書き確認」を「強制上書き」とした場合は常に後から解凍したファイルが無条件に上書きされますが、そうでない場合は確認メッセージが表示されます。
ファイル参照系のモジュールやフォームも本プロジェクトに持ち込んでいますが、このページでの説明範囲ではないのでコードの紹介は行なっていません。関心がある方はソースコードをご覧下さい。

7-ZIP32.DLLを操作する中核部分のコードです。

clsArchiveBySevenZip32(クラス)のコードはこのようになっています。
64ビット版Excelの場合は、7-ZIP64.DLLとなります。


'***************************************************************************************************
'   ZIPファイル圧縮／解凍機能(7-ZIP32.DLL必須)                  clsArchiveBySevenZip32(Class)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'   [ZIP圧縮・解凍DLL]
'   ・7-ZIP32.dll (32ビット版Excel時に必要です)
'   ・7-ZIP64.dll (64ビット版Excel時に必要です)
'***************************************************************************************************
' 変更日付 Rev   変更履歴内容---------------------------------------------------------------------->
' 12/03/04(1.0.0)新規作成
' 17/09/24(2.0.0)クラス化移行(modArchiveBySevenZip32⇒clsArchiveBySevenZip32)
' 17/09/30(2.0.0)圧縮対象ファイルの複数指定機能対応(フォルダの場合は1件のみ)
' 19/10/28(2.1.0)Declare記述の変更(64ビット版Excel対応⇒7-ZIP64.DLL必須)
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsZIP As String = ".zip"
Private Const g_cnsEXE As String = ".exe"
'---------------------------------------------------------------------------------------------------
#If VBA7 And Win64 Then
Private Const g_cns7ZipName As String = "7-ZIP64"
' 7-ZIP64のバージョンを取得する(7-ZIP64)
Private Declare PtrSafe Function SevenZipGetVersion Lib "7-ZIP64.DLL" () As Integer
' 7-ZIP64の動作状態を確認する(7-ZIP64)
Private Declare PtrSafe Function SevenZipGetRunning Lib "7-ZIP64.DLL" () As Boolean
' ZIP圧縮を操作する(7-ZIP64)
Private Declare PtrSafe Function SevenZip Lib "7-ZIP64.DLL" _
    (ByVal hWnd As LongPtr, _
     ByVal szCmdLine As String, _
     ByVal szOutput As String, _
     ByVal dwSize As Long) As Long
#Else
Private Const g_cns7ZipName As String = "7-ZIP32"
' 7-ZIP32のバージョンを取得する(7-ZIP32)
Private Declare Function SevenZipGetVersion Lib "7-ZIP32.DLL" () As Integer
' 7-ZIP32の動作状態を確認する(7-ZIP32)
Private Declare Function SevenZipGetRunning Lib "7-ZIP32.DLL" () As Boolean
' ZIP圧縮を操作する(7-ZIP32)
Private Declare Function SevenZip Lib "7-ZIP32.DLL" _
    (ByVal hWnd As Long, _
     ByVal szCmdLine As String, _
     ByVal szOutput As String, _
     ByVal dwSize As Long) As Long
#End If
#If VBA7 Then
' ウィンドウハンドルを返す
Private Declare PtrSafe Function FindWindow Lib "USER32.dll" Alias "FindWindowA" _
    (ByVal lpClassName As Any, ByVal lpWindowName As Any) As LongPtr
#Else
' ウィンドウハンドルを返す
Private Declare Function FindWindow Lib "USER32.dll" Alias "FindWindowA" _
    (ByVal lpClassName As Any, ByVal lpWindowName As Any) As Long
#End If
'---------------------------------------------------------------------------------------------------
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
'* 機能　　：ZIPファイル圧縮機能(7-ZIP32.dll必須)
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = 圧縮対象のフォルダ／ファイル名(Variant) ※複数の場合は配列をセットする
'* 　　　　　Arg2 = 圧縮後のファイル名(String)              ※Ref参照
'* 　　　　　Arg3 = エラーメッセージ(Atring)                ※Ref参照
'* 　　　　　Arg4 = 既存ファイルに追加(Boolean)             ※Option
'* 　　　　　Arg5 = パスワード(String)                      ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日　：2012年03月04日
'* 作成者　：井上　治
'* 更新日　：2017年09月30日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Friend Function ArchiveBySevenZip32(ByRef vntSrcPath As Variant, _
                                    ByRef strZipFile As String, _
                                    ByRef strErrMSG As String, _
                                    Optional ByVal blnAppend As Boolean = False, _
                                    Optional ByVal strPassword As String = "") As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim strCommand As String                                        ' コマンドライン
    ArchiveBySevenZip32 = False
    Set objFso = New FileSystemObject
    '-----------------------------------------------------------------------------------------------
    ' 圧縮指定値及び環境チェック(+コマンドライン編集)
    If Not FP_CheckArchive(objFso, _
                           vntSrcPath, _
                           strZipFile, _
                           strCommand, _
                           strErrMSG) Then
        Set objFso = Nothing
        Exit Function
    End If
    '-----------------------------------------------------------------------------------------------
    ' 現行圧縮ファイルを削除
    If (objFso.FileExists(strZipFile) And Not blnAppend) Then
        On Error Resume Next
        objFso.DeleteFile strZipFile, True
        ' エラーか
        If Err.Number <> 0 Then
            strErrMSG = "出力ファイルの事前削除に失敗しました。" & vbCrLf & Err.Description
            Err.Clear
            Set objFso = Nothing
            On Error GoTo 0
            Exit Function
        End If
        On Error GoTo 0
    End If
    Set objFso = Nothing
    '-----------------------------------------------------------------------------------------------
    ' コマンドラインの編集(ZIP圧縮)続き
    If strPassword <> "" Then
        strCommand = strCommand & " -p" & strPassword       ' パスワード
    End If
    strCommand = strCommand & " -mx=9 "                     ' 圧縮率
    '-----------------------------------------------------------------------------------------------
    ' 7-ZIP32コマンドライン処理
    ArchiveBySevenZip32 = LetCommandSevenZip(strCommand, strErrMSG)
End Function

'***************************************************************************************************
'* 処理名　：ExtractBySevenZip32
'* 機能　　：ZIP圧縮ファイルの解凍機能(7-ZIP32.dll必須)
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = ZIP圧縮ファイル(String)
'* 　　　　　Arg2 = 解凍先フォルダ名(String)
'* 　　　　　Arg3 = エラーメッセージ(Atring)                ※Ref参照
'* 　　　　　Arg4 = 上書き指定(Boolean)                     ※Option
'* 　　　　　Arg5 = パスワード(String)                      ※Option
'---------------------------------------------------------------------------------------------------
'* 作成日　：2012年03月04日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Friend Function ExtractBySevenZip32(ByVal strZipFile As String, _
                                    ByVal strDstPath As String, _
                                    ByRef strErrMSG As String, _
                                    Optional ByVal blnOverWrite As Boolean = False, _
                                    Optional ByVal strPassword As String = "") As Boolean
    '-----------------------------------------------------------------------------------------------
    ExtractBySevenZip32 = False
    ' 解凍指定値及び環境チェック
    If Not FP_CheckExtract(strZipFile, strDstPath, strErrMSG) Then Exit Function
    '-----------------------------------------------------------------------------------------------
    ' コマンドラインの編集(ZIP解凍)
    Dim strCommand As String
    strCommand = "x "                                       ' ZIP解凍
    strCommand = strCommand & " """ & strZipFile & """"     ' 圧縮ファイル名
    strCommand = strCommand & " -o""" & strDstPath & """"   ' 解凍先フォルダ
    strCommand = strCommand & " *.* -r"                     ' 全て解凍
    If blnOverWrite Then
        strCommand = strCommand & " -aoa"                   ' 上書き許可
    End If
    If strPassword <> "" Then
        strCommand = strCommand & " -p" & strPassword       ' パスワード
    End If
    '-----------------------------------------------------------------------------------------------
    ' 7-ZIP32コマンドライン処理
    ExtractBySevenZip32 = LetCommandSevenZip(strCommand, strErrMSG)
End Function

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

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

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

'***************************************************************************************************
'* 処理名　：FP_CheckExtract
'* 機能　　：解凍指定値及び環境チェック
'---------------------------------------------------------------------------------------------------
'* 返り値　：処理成否(Boolean)
'* 引数　　：Arg1 = ZIP圧縮ファイル(String)
'* 　　　　　Arg2 = 解凍先フォルダ名(String)
'* 　　　　　Arg3 = エラーメッセージ(String)            ※Ref参照
'---------------------------------------------------------------------------------------------------
'* 作成日　：2017年09月24日
'* 作成者　：井上　治
'* 更新日　：2017年09月24日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_CheckExtract(ByVal strZipFile As String, _
                                 ByVal strDstPath As String, _
                                 ByRef strErrMSG As String) As Boolean
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    FP_CheckExtract = False
    '-----------------------------------------------------------------------------------------------
    ' 圧縮ファイルの存在確認
    If Trim(strZipFile) = "" Then
        strErrMSG = "ZIP圧縮ファイルが指定されていません。"
        Exit Function
    ElseIf LCase(Right(strZipFile, 4)) <> g_cnsZIP Then
        strErrMSG = "ZIP圧縮ファイルの形式が誤っています。"
        Exit Function
    ElseIf Trim(strDstPath) = "" Then
        strErrMSG = "解凍先フォルダが指定されていません。"
        Exit Function
    End If
    Set objFso = New FileSystemObject
    On Error Resume Next
    If Not objFso.FileExists(strZipFile) Then
        strErrMSG = "ZIP圧縮ファイルが存在しません。"
        Set objFso = Nothing
        On Error GoTo 0
        Exit Function
    End If
    If Err.Number <> 0 Then
        strErrMSG = "ZIP圧縮ファイルが参照できません。" & vbCrLf & Err.Description
        Err.Clear
        Set objFso = Nothing
        On Error GoTo 0
        Exit Function
    End If
    '-----------------------------------------------------------------------------------------------
    ' 解凍先フォルダの存在確認
    If Not objFso.FolderExists(strDstPath) Then
        strErrMSG = "解凍先フォルダが存在しません。"
        Set objFso = Nothing
        On Error GoTo 0
        Exit Function
    End If
    If Err.Number <> 0 Then
        strErrMSG = "解凍先フォルダが参照できません。" & vbCrLf & Err.Description
        Err.Clear
        Set objFso = Nothing
        On Error GoTo 0
        Exit Function
    End If
    Set objFso = Nothing
    On Error GoTo 0
    FP_CheckExtract = True
End Function

'***************************************************************************************************
'* 処理名　：FP_GetWindowHwnd
'* 機能　　：ウィンドウハンドル取得
'---------------------------------------------------------------------------------------------------
'* 返り値　：ウィンドウハンドル(Long)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2012年03月04日
'* 作成者　：井上　治
'* 更新日　：2019年10月28日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
#If VBA7 Then
Private Function FP_GetWindowHwnd() As LongPtr
    '-----------------------------------------------------------------------------------------------
    ' 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
#Else
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
#End If

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

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

上のサンプルで利用しているプロシージャ以外にそれらのプロシージャから呼ばれるコマンドライン処理の部分を別プロシージャにしてあり、これもFriend参照可能にしてあるのでサンプルと異なるスイッチの利用などであればコマンドラインを編集した上で「LetCommandSevenZip」を呼び出すようにしてみて下さい。

←ArchiveBy7-ZIP32.zip
(96KB)

ファイル圧縮（7-ZIP32、7-ZIP64利用)

ZIP書庫の圧縮・解凍なら、7-ZIP32.DLLでしょう。