#使い方
「チェック開始」ボタン押下で所定のフォルダ配下の各ファイルに対して、パスワード有無を判定します。
チェック対象ファイルはxls*, doc*, ppt*, zip, pdfです。

pdfに関しては、手動でファイル名押下して、直接ファイルを開いて確認する仕様としています。

#注意
Cドライブ直下など、ファイルが大量にある場所を指定しての実行は危険です＞＜
できれば細かくフォルダを分けてチェックしていってください。

Office2010で実行すると、パスワードなしのExcelファイルをチェックした際にExcelプロセスが残ってしまう事象が起こります。Office2016での実行を推奨します。

プロセスが残ってしまった場合は、コマンドプロンプトで↓を実行してExcelプロセスを切ってください。

taskkill /im EXCEL.EXE /F

#ソース
「チェック開始」ボタンにpassCheck()を登録すること。

'=======================================================================
'
' File Name       : ファイルパスワードチェック.xlsm
' Creation Date   : 2019/04/03
'
' Copyright (c) 2019 irohamaru. All rights reserved.
'
' This source code or any portion thereof must not be
' reproduced or used in any manner whatsoever.
'
'=======================================================================

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 & "\*")
            Do While buf <> ""
                fileCount = fileCount + 1
                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