Zipファイルのパスワード有無を判別したい

前提・実現したいこと

Zipファイルにパスワードが掛かっているかどうかを判定するコードを作成しているのですが、どうしても上手くいかず、、
参考にさせて頂いたコードで作業様フォルダを作成し、その中でzipフォルダを解凍すると、解凍されたフォルダ以下のファイルがカウントされず、間違った結果が出力されてしまいます。
解決策をご教示いただきたいです。
以下参考にさせて頂いたコードのURLです。こちらのコードを使用させていただき、こちらのzipのcase部分を2個目のURLに記載されている回答に記載されているコードに修正したものに書き換えています。

発生している問題・エラーメッセージ

Zipを解凍し、ファイル数をカウントする際に解凍されたフォルダ以下のファイルがカウントされない

該当のソースコード


Option Explicit

Const MAINSHEETNAME As String = "メイン"
Const SEARCHCELLRNG As String = "H3"
Const HEADERROW As Integer = 5
Const FOLDERCOL As String = "H"
Const FILENMCOL As String = "I"
Const RESULTCOL As String = "J"
Const CHECK_OK As String = "パスワード保護OK"
Const CHECK_NG As String = "パスワード保護NG"
Const NO_CHECK As String = "チェック対象外"
Const CHECK_ERROR As String = "チェックエラー"
Const MSG_EXCEL As String = "入力したパスワードが間違っています。"
Const MSG_PPT As String = "読み取りパスワードをもう一度入力してください"
Const MSG_WORD As String = "パスワードが正しくありません。"
Const MSG_PDF As String = "パスワードが正しくありません。"
Const MSG_ZIP As String = "入力したパスワードが間違っています。"

' パスワードチェック
Sub passCheck()

    Dim mainSheet As Worksheet
    Set mainSheet = Worksheets(MAINSHEETNAME)
    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    ' チェック対象フォルダパス取得
    Dim folderPath As String, folderExist As String

    folderPath = mainSheet.Range(SEARCHCELLRNG).Value
    folderExist = Dir(folderPath, vbDirectory)

    ' フォルダ存在チェック
    If folderExist = "" Then
        MsgBox "チェック対象のフォルダが存在しません。" & vbCrLf & _
                    "処理を終了します。", vbExclamation
        GoTo passCheckErr1
    End If

    ' ファイル一覧初期化
    Call listClear(mainSheet)
    ' ファイル一覧取得
    Call FileSearch(objFSO.GetFolder(folderPath))

    ' 最下行取得
    Dim maxRow As Integer
    If mainSheet.Range(FOLDERCOL & (HEADERROW + 1)).Value = "" Then
        MsgBox "ファイルなしエラー"
        GoTo passCheckErr1
    Else
        maxRow = mainSheet.Range(FOLDERCOL & HEADERROW).End(xlDown).Row
    End If

    ' パスワードチェック
    Dim i As Integer
    For i = HEADERROW + 1 To maxRow
        ' チェック結果格納用
        ' 1:チェックOK, 2:チェックNG, 3:チェック対象外ファイル
        Dim checkResult As Integer

        With mainSheet
            ' ファイルパス取得
            Dim f As String
            f = .Range(FOLDERCOL & i).Value & "\" & .Range(FILENMCOL & i).Value

            ' パスワードチェック
            checkResult = IsLockedFile(f)

            ' 結果記入
            Select Case checkResult
                Case 1
                    .Range(RESULTCOL & i).Value = CHECK_OK
                Case 2
                    .Range(RESULTCOL & i).Value = CHECK_NG
                    .Range(RESULTCOL & i).Interior.Color = RGB(255, 0, 0)
                Case 3
                    .Range(RESULTCOL & i).Value = NO_CHECK
                    .Range(RESULTCOL & i).Interior.Color = RGB(255, 255, 0)
                Case Else
                    .Range(RESULTCOL & i).Value = CHECK_ERROR
                    .Range(RESULTCOL & i).Interior.Color = RGB(243, 152, 0)
            End Select

        End With

    Next

passCheckErr1:
    Set mainSheet = Nothing
    Set objFSO = Nothing

    MsgBox "パスワードチェックが完了しました。"

End Sub

' ファイル一覧取得＆記入
Sub FileSearch(ByVal folderPath As String)

    Dim objFSO As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Dim mainSheet As Worksheet
    Set mainSheet = Worksheets(MAINSHEETNAME)

    Dim objFolder, objSubFolders As Object
    Set objFolder = objFSO.GetFolder(folderPath)
    Set objSubFolders = objFolder.SubFolders

    On Error Resume Next

    Dim sf As Object
    For Each sf In objSubFolders
        FileSearch sf
    Next
    Set sf = Nothing

    Dim f As Object
    Dim rowNum, maxRow As Integer

    ' 最下行取得
    If mainSheet.Range(FOLDERCOL & (HEADERROW + 1)).Value = "" Then
        maxRow = HEADERROW
    Else
        maxRow = mainSheet.Range(FOLDERCOL & HEADERROW).End(xlDown).Row
    End If
    rowNum = maxRow + 1

    For Each f In objFolder.Files
        With mainSheet
            .Hyperlinks.Add Anchor:=.Range(FOLDERCOL & rowNum), _
                            Address:=objFSO.GetParentFolderName(f.Path), _
                            TextToDisplay:=objFSO.GetParentFolderName(f.Path)
            .Hyperlinks.Add Anchor:=.Range(FILENMCOL & rowNum), _
                            Address:=f.Path, _
                            TextToDisplay:=objFSO.GetFileName(f.Path)
        End With
        rowNum = rowNum + 1
    Next
    Set f = Nothing

    Set objSubFolders = Nothing
    Set objFolder = Nothing
    Set mainSheet = Nothing
    Set objFSO = Nothing

End Sub


Private Sub listClear(ByVal sh As Worksheet)

    ' セル一覧の最下行を取得し、セルをクリア
    Dim maxRow As Integer

    maxRow = sh.Range(FOLDERCOL & HEADERROW).End(xlDown).Row
    sh.Range(FOLDERCOL & (HEADERROW + 1) & ":" & RESULTCOL & maxRow).Clear
    sh.Range(FOLDERCOL & (HEADERROW + 1) & ":" & RESULTCOL & maxRow).Font.Name = "メイリオ"
    sh.Range(FOLDERCOL & (HEADERROW + 1) & ":" & RESULTCOL & maxRow).Font.Size = 10

End Sub


'パスワード保護されているブックで TRUE を返す
Function IsLockedFile(ByVal tgtPath As String) As Integer

    Dim errDescription As String
    Dim errNum As Long

    Dim objFSO, objShell As Object
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Shell.Application")

    Dim cnsMsg As String, ext As String, skipFlg As Boolean: skipFlg = False
    ext = objFSO.GetExtensionName(tgtPath)

    On Error Resume Next

    Select Case ext
        Case "xls", "xlsx", "xlsm"
            cnsMsg = MSG_EXCEL

            Dim objExcel, wb As Object
            Set objExcel = CreateObject("Excel.Application")
            Set wb = objExcel.Workbooks.Open(tgtPath, Password:=vbNullString)

            errDescription = Err.Description
            errNum = Err.Number

            objExcel.DisplayAlart = False
            wb.Close (False)
            objExcel.DisplayAlart = True

            Set wb = Nothing
            objExcel.Quit
            Set objExcel = Nothing

        Case "ppt", "pptx", "pptm"
            cnsMsg = MSG_PPT

            Dim p, ppt As Object
            Set p = CreateObject("PowerPoint.Application")
            Set ppt = p.Presentations.Open(tgtPath & "::unknown", WithWindow:=msoFalse)

            errDescription = Err.Description
            errNum = Err.Number

            ppt.Close
            Set ppt = Nothing
            p.Quit
            Set p = Nothing

        Case "doc", "docx", "docm"
            cnsMsg = MSG_WORD

            Dim wd, doc As Object
            Set wd = CreateObject("Word.Application")
            Set doc = wd.Documents.Open(tgtPath, passworddocument:="unknown", Visible:=False)

            errDescription = Err.Description
            errNum = Err.Number

            doc.Close
            Set doc = Nothing
            wd.Quit
            Set wd = Nothing

        Case "pdf"
            ' Excelのハイパーリンク押下⇒開いて確認で回避？

        Case "zip"
            Dim folderPath As String
            folderPath = objFSO.GetParentFolderName(tgtPath)

             ' 作業用フォルダ作成
            Dim mkDirPath As String
            Dim cnt As Integer: cnt = 0
            While cnt < 10
                mkDirPath = folderPath & "\" & "workfolder_" & Rnd
                If Dir(mkDirPath, vbDirectory) = "" Then
                    MkDir (mkDirPath)
                    cnt = 10
                End If
            Wend

            Dim objZip As Object
            Dim result As Integer
             'なぜか二重カッコが必要
             '進捗ダイアログを表示しない
            objShell.Namespace((mkDirPath)).CopyHere objShell.Namespace((tgtPath)).Items, &H4 + &H40 + &H400

            ' 一時フォルダ内のファイル数カウント

            

            Dim buf As String, fileCount As Long

buf = Dir(mkDirPath & "*", vbDirectory)
Do While buf <> ""
If buf <> "." And buf <> ".." Then
fileCount = fileCount + 1
End If
buf = Dir()
Loop

            Select Case fileCount
                Case Is > 0
                    ' パスワードチェックNG
                    IsLockedFile = 2
                Case Is = 0
                    ' パスワードチェックOK
                    IsLockedFile = 1
                Case Else
                    ' パスワードチェックエラー
                    IsLockedFile = 4
            End Select

            ' 一時フォルダ削除
            objFSO.DeleteFolder (mkDirPath)

            skipFlg = True

        Case Else
            ' チェック対象外ファイルの場合

    End Select

    On Error GoTo 0

    ' zipファイルチェック以外の場合のみ実行
    If skipFlg = False Then
        ' 対象外フォイルの場合
        If cnsMsg = "" Then
            IsLockedFile = 3
            GoTo IsLockedFileClose
        End If

        If InStr(errDescription, cnsMsg) > 0 Then
            ' パスワードチェックOK
            IsLockedFile = 1

        ElseIf Err.Number = 0 Then

            ' パスワードチェックNG
            IsLockedFile = 2

        Else
            Err.Raise errNum, , errDescription
        End If
    End If

IsLockedFileClose:
    Set objShell = Nothing
    Set objFSO = Nothing

End Function


### 補足情報（FW/ツールのバージョンなど）

参照させていただいたのは下記サイト様です。

https://qiita.com/irohamaru/items/6021327a5c39422fa2f4

https://teratail.com/questions/240188

y_waiwai

2021/10/04 08:00

コードを提示しよう

jinoji

2021/10/04 08:45

・質問のタイトルと発生している問題がちぐはぐですね。・ZIPファイルそのものにパスワードがかかっているのか、　それともZIPファイルの中のExcelファイルなどにパスワードがかかっているのか、　それともその両方のケースがあり得るのか、・間違った結果とはどのようなものか。実際より大きいのか小さいのか。（小さい場合、解凍途中でカウントされたのではと疑いたくなる）

takahiro_y2j

2021/10/04 09:05

① 基本的にはzipファイルにパスワードがかかっています。Zipで圧縮したフォルダ内にはパスワードがかかっているExcelファイルなどが混在していることもありえます。 ② パスワード有無に関わらずどちらもNG判定となります。 (解凍した際のサブフォルダがカウントされてしまうため、サブフォルダ内ファイルまでカウントされない状態です。)