【ExcelVBA】ZIPファイルを7-zip32.dllで作成

Option Explicit
'7-zip32.DLLのAPI宣言
'[hwnd]ウィンドウハンドル,[szCmdLine]コマンド文字列
'[szOutput]結果を返すバッファ,[dwSize]バッファのサイズ
'戻り値   正常終了= 0   エラー時 <> 0
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

'ZIPファイルを作成（圧縮コマンド作成）
'引数 szTgPath：圧縮するファイルまたはフォルダーのパス
'     szZIPName：ZIPファイルのパス
'     szPWord：パスワード　省略可
'返り値　成功したら True、失敗したらFalse
Public Function CompressZIP(szTgPath As String, szZIPName As String, _
                        Optional szPWord As String = "") As Boolean
    Dim szCmd As String
    szCmd = "a -tzip -mx9 -hide "
    If szPWord <> "" Then szCmd = szCmd & "-P" & szPWord & " "
    szCmd = szCmd & dq(szZIPName) & " " & dq(szTgPath)
    CompressZIP = DoSevenZIP(szCmd) = 0
End Function
 
'7-Zip.dllへ実行コマンドを渡す
Private Function DoSevenZIP(szCmd As String) As Long
    Dim szRet As String * 1024    
    DoSevenZIP = SevenZip(0, szCmd, szRet, 1024)
    If DoSevenZIP <> 0 Then MsgBox (Left(szRet, InStr(szRet, vbNullChar) - 1))
    'ログ用に実行したコマンドを保存
    strcmd = strcmd & vbCrLf & szCmd
End Function

'ダブルクォーテーション用
Public Function dq(ByVal Text As String) As String
    dq = """" & Replace(Text, """", """""") & """"
End Function

Option Explicit
Public strcmd As String
'*******************************************
'* ZIPファイル作成実行
'*******************************************
Sub CmdMake7Zip()
    Dim lngRow As Long          '開始行
    Dim lngRowMax As Long       '最終行
    Dim i As Long               '行指定用
    Dim strFoldFiles As String  '圧縮対象フォルダ&ファイル名
    Dim strDstFullPath As String 'ZIPのフルパス
    Dim strDstPath As String    'ZIPのパス
    Dim strZipName As String    'ZIPファイル名
    Dim strPW As String         'パスワード
    Dim strApndRep As String    '追加or置換
    Dim strErr As String        'エラーメッセージ
    Dim objFSO As FileSystemObject  'FileSystemObject
    Set objFSO = New FileSystemObject
    
    '7-Zip.dllのパス設定（Systmに無い場合のため）
    ChDrive ThisWorkbook.path
    ChDir ThisWorkbook.path
    
    lngRowMax = Cells(Rows.Count, 2).End(xlUp).Row  '対象データ最終行
    lngRow = 2  'データ開始行
        
    'ZIP圧縮ファイル名
    strDstFullPath = Trim(Cells(2, 9).Value)
    strDstPath = Left(strDstFullPath, InStrRev(strDstFullPath, "\")) 'ファイル名カット
    strZipName = Left(strDstFullPath, InStr(strDstFullPath, ".") - 1) '拡張子カット
    strZipName = Right(strZipName, Len(strZipName) - Len(strDstPath))
    '追加or置換判定（置換の場合ZIPファイルを削除）
    strApndRep = Cells(5, 9).Value
    If strApndRep = "置換" Then
        If objFSO.FileExists(strDstFullPath) Then
            On Error Resume Next
            objFSO.DeleteFile strDstFullPath, True
            If Err.Number <> 0 Then
                strErr = "置換ZIPファイルの事前削除に失敗！" _
                            & vbCrLf & Err.Description
                Err.Clear
                On Error GoTo 0
                Set objFSO = Nothing
                Exit Sub
            End If
            On Error GoTo 0
        End If
    End If
    'ログ用txtファイル見出し
    strcmd = "cmd　sw1　sw2　sw3 PW ZIPファイル名 Path/FileName"
    '圧縮対象数分のループ処理
    For i = lngRow To lngRowMax
        '対象フォルダ&ファイル名の存在確認
        strFoldFiles = Trim(Cells(i, 2).Value)
        If Not objFSO.FileExists(strFoldFiles) Then
            If objFSO.FolderExists(strFoldFiles) Then
                'フォルダ指定はフォルダ内の全てを
                strFoldFiles = strFoldFiles & "\*"
            Else
                strErr = "圧縮対象が実在しません。" _
                                & vbCrLf & strFoldFiles
                Set objFSO = Nothing
                Exit Sub
            End If
        End If
        'パスワード（個別設定を優先する）
        strPW = Trim(Cells(i, 7).Value)
        If strPW = "" Then strPW = Trim(Cells(7, 9).Value)
        '-------------------------------------------
        '7-Zip.dllの処理へ
        Call CompressZIP(strFoldFiles, strDstFullPath, strPW)
        '-------------------------------------------
    Next
    'ZIP作成後ログをテキストファイルに書き出す
    Dim strPath As String
    strPath = strDstPath & strZipName & ".txt"
    
    With objFSO
        If Not .FileExists(strPath) Then
            .CreateTextFile (strPath)
        End If
        With .OpenTextFile(strPath, 8) '8:ForAppending
            .WriteLine strcmd
            .Close
        End With
    End With
    Set objFSO = Nothing
    MsgBox "圧縮処理が終了しました！" & vbCrLf & _
            "ZIPファイルを確認してください。"
End Sub

'*******************************************
'* 圧縮対象ファイル選択指定
'*******************************************
Sub CmdSelectFiles()
    Dim n As Long
    Dim re As Long
    Dim i As Long

    '新規取得か追加取得かを選択
    n = Cells(Rows.Count, 2).End(xlUp).Row
    re = vbNo '初期化
    If n > 1 Then
        re = MsgBox("すでにデータがあります。" & _
                    "処理を選択してください。" & vbCrLf _
                    & "「はい]＝追加取得,「いいえ]＝新規取得", _
                    (vbYesNo + vbExclamation), "処理選択")
    End If
    '選択されたファイル名をセルに格納する処理
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True    '複数選択可
        .Filters.Clear  'フィルタを初期化してセット
        .Filters.Add "Microsoft Excelファイル", "*.xls?"
        .Filters.Add "全てのファイル", "*.*"
        .FilterIndex = 1
        .InitialFileName = ThisWorkbook.path '初期表示フォルダの設定
                        
        '新規の場合セルをクリアする
        If re = vbNo Then Range(Cells(2, 2), Cells(101, 8)).ClearContents
        If .Show = -1 Then  'ダイアログ表示
            For i = 1 To .SelectedItems.Count
                If re = vbYes Then
                    Cells(n + i, 2).Value = .SelectedItems(i)
                Else
                    '新規の場合
                    Cells(i + 1, 2).Value = .SelectedItems(i)
                End If
            Next i
        Else
            'キャンセルされた場合
            MsgBox "ファイル選択がキャンセルされました。", vbExclamation
            Exit Sub
        End If
    End With
End Sub
'*******************************************
'* ZIPファイルの保存先指定
'*******************************************
Sub CmdSelectSaveZip()
    Dim strFilename As String 'ファイル名
    
    strFilename = Application.GetSaveAsFilename( _
                    FileFilter:="ZIPファイル,*.zip,全てのファイル,*.*", _
                    FilterIndex:=1, _
                    InitialFileName:="ZIPファイル名.zip", _
                    Title:="保存ZIPファイルの指定")
    
    '選択されたファイル名をセルに格納
    If strFilename = "False" Then
        Cells(2, 9).Value = ""
    Else
        Cells(2, 9).Value = strFilename
    End If
End Sub
'*******************************************
'* 圧縮対象フォルダ選択指定
'*******************************************
Sub CmdSelectFolder()
    Dim strPathname As String ' フォルダ名
    Dim n As Long
    Dim re As Long
    
    '「フォルダ選択」ダイアログを表示(modFolderPicker1)
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "ZIP圧縮対象フォルダの参照"
        .AllowMultiSelect = False
        If .Show = False Then
            MsgBox "選択されませんでした"
            Exit Sub
        End If
        strPathname = .SelectedItems(1)
    End With
    'フォルダが選択されていたらセルに格納する処理
    n = Cells(Rows.Count, 2).End(xlUp).Row
    '新規取得か追加取得かを選択
    re = vbNo '初期化
    If n > 1 Then
        re = MsgBox("すでにデータがあります。" & _
                    "処理を選択してください。" & vbCrLf _
                    & "「はい]＝追加取得,「いいえ]＝新規取得", _
                    (vbYesNo + vbExclamation), "処理選択")
    End If
    If re = vbYes Then
        Cells(n + 1, 2).Value = strPathname
    Else
        '新規の場合セルをクリアする
        Range(Cells(2, 2), Cells(101, 8)).ClearContents
        Cells(2, 2).Value = strPathname
    End If
End Sub