zip形式で圧縮する。（7-zipのdllによる圧縮）

VBAを利用してzip形式でファイルを圧縮するには7-zipのDLLを利用して7-zipのコマンドを実行することでzipファイルを作成することができます｡
　※7-zipのDLL(32bit or 64bit)についてはご自身でダウンロードをお願いします。

また7-zipのDLLを利用すればzipファイルにパスワードを設定することもできます。
7zipのコマンドで利用できるパラメータは他にも多々あるので用途に応じたパラメータを設定や実行結果のログ出力もできます。

DLLの配置について通常ではパスの通っている場所への配置や「C:\Windows\SysWOW64」や「C:\Windows\System32」に配置（※１）して関数などを呼び出しますが、今回は任意の場所にDLLファイルを置いて実行させる方法を記載しています。
やり方としては Declareの宣言部で「Declare Function aaa Lib “C:\VBA\aaa.dll” (ByVal ～」のように絶対パスで指定する方法とAPIのLoadLibrary関数を利用して任意の場所に置いたDLLをロードする方法があります。
今回掲載しているサンプルコードではLoadLibrary関数を利用する方法で実行しています。
（※１）通常は、Windows 64bit版を利用している場合、64bit版のDLLの導入先は「C:\Windows\System32」、32bit版のDLLの導入先は「C:\Windows\SysWow64」に配置します。
もしLoadLibraryなどを利用せずにDLLを呼び出すには今回の利用する7-zip32.dllの場合、32bit版なので「C:\Windows\SysWow64」にDLLを配置することになります。

サンプルコードでは「C:\VBA\zip_txt」フォルダをパスワード付与して圧縮しています。
なお実行結果はWindows(64bit)、Office(32bit)の環境下で実行した結果になります。

　●zipに圧縮

#If VBA7 And Win64 Then
    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
    Declare PtrSafe Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" _
            (ByVal fileName As String) As Long
    Declare PtrSafe Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
#Else
    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
    Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" _
            (ByVal fileName As String) As Long
    Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
#End If

'*****************************************************************
'　zip圧縮処理(7zDLL ※任意の場所にDLLを配置)
'*****************************************************************
Sub makeZip_7zDLL()
    
    'DLLのロード
    '指定のフォルダ配下に置いたDLLを一括でロードさせています。
    Dim lHndl As Long
    lHndl = LoadLibrary("C:\VBA\DLL\*")
    
    '作成するzipファイルのパス
    Dim sZipPath As String
    sZipPath = "C:\VBA\archive\ZipTest_7zDLL.zip"
    
    '圧縮させるフォルダ、ファイルの指定
    Dim sTarget As String
    sTarget = "C:\VBA\zip_txt\"
    
    
    '設定するパスワード
    Dim sPassword As String
    sPassword = "pass123"
   
    
    '圧縮処理
    Dim lRtn As Long
    lRtn = makeZip_7zDllCmd(sZipPath, sTarget, sPassword)
    
    'パスワード設定が不要であれば下記を使用
    'lRtn = makeZip_7zDllCmd(sZipPath, sTarget)
    
    
    '実行結果確認
    If lRtn = 0 Then
        MsgBox "完了"
    Else
        MsgBox "圧縮処理でエラーが発生しました。"
    End If
    
    'DLLの解放
    Call FreeLibrary(lHndl)
    
End Sub

'*****************************************************************
'　コマンドの作成と実行
'-----------------------------------------------------------------
'　　第１引数：作成するzipファイルのパス
'　　第２引数：圧縮させるフォルダ、ファイルのパス
'　　第３引数：設定するパスワード
'-----------------------------------------------------------------
'　　戻り値　：実行結果(0:正常終了、0以外:異常終了)
'*****************************************************************
Public Function makeZip_7zDllCmd(getZipPath As String, getTarget As String, _
                                 Optional getPassword As String = "") As Long
    
    'コマンドの作成（基礎部分）
    Dim sCmd As String
    '設定してるパラメータは下記になります。
    '　-a      archiveにファイルを追加
    '　-tzip   archiveの種類をzipに設定
    '　-mx9    圧縮レベルを9に設定（最大）
    '　-hide   処理進行状況のダイアログを表示しない
    sCmd = "a -tzip -mx9 -hide" & Space(1)
    
    'パスワード指定があればパスワード設定ありのコマンドにする
    If getPassword <> "" Then
        'コマンドの作成（パスワード設定の追加）
        sCmd = sCmd & "-P" & getPassword & Space(1)
    End If
    
    'コマンドの作成（ファイル情報の追加）
    '指定のパスにスペースがある場合は文字列の前後を""を含めた形の文字列にする必要がある
    sCmd = sCmd & setDQ(getZipPath) & Space(1) & setDQ(getTarget)
    
    '圧縮の実行
    Dim sLog As String * 1024
    Dim lRtn As Long
    lRtn = SevenZip(0, sCmd, sLog, 1024)
    
    '実行結果ログ
    Debug.Print (Left(sLog, InStr(sLog, vbNullChar) - 1))
    
    makeZip_7zDllCmd = lRtn

End Function
 
'*****************************************************************
'　'ダブルクォーテーション設定
'-----------------------------------------------------------------
'　　第１引数：文字列
'-----------------------------------------------------------------
'　　戻り値　：文字列の前後に"を設定した状態の文字列
'*****************************************************************
Function setDQ(ByVal getStr As String) As String
    
    setDQ = """" & Replace(getStr, """", """""") & """"

End Function

　■実行前

　■実行結果