ファイルのパスワード有無確認

Option Explicit
Private n As Long

'-----------------------------------------
'メイン処理
'-----------------------------------------
Sub Main()
    Dim Path As String
    Cells.ClearContents
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path
        If .Show Then
            Path = .SelectedItems(1)
        Else
            MsgBox "フォルダーが選択されなかったので終了します"
            Exit Sub
        End If
    End With
    
    'ファイル一覧の作成
    'セルへ格納
    Cells(2, 1) = "No"
    Cells(2, 2) = "ファイル名"
    Cells(2, 3) = "拡張子"
    Cells(2, 4) = "ファイル形式"
    Cells(2, 5) = "パスワード"
    n = 2
    'Application.ScreenUpdating = False
    Call MakeFileList(Path)
    'Application.ScreenUpdating = True
    DoEvents
    
    'パスワードチェック
    Dim r As Long
    r = 2
    Do
        r = r + 1
        If Cells(r, 1) = "" Then Exit Do
        Cells(r, 5).Select
        Cells(r, 5) = IsPass(Cells(r, 2) & "\" & Cells(r, 3))
    Loop
    
    MsgBox r - 3 & "件のチェックが完了しました"
    
End Sub
 
'-----------------------------------------
'ファイル一覧作成
'-----------------------------------------
Sub MakeFileList(strPath As String)
 
    Dim StrFolder As String, StrFile As String
    Dim Fso As Object, f As Object, fd As Object
    Set Fso = CreateObject("Scripting.FileSystemObject")
    
    For Each f In Fso.GetFolder(strPath).Files
        n = n + 1
        Cells(n, 1) = n - 2
        Cells(n, 2) = f.Name
        Cells(n, 3) = Fso.GetExtensionName(f)
        
        ' ファイル形式の判別
        Select Case LCase(Fso.GetExtensionName(f))
            Case "doc", "docx", "docm"
                Cells(n, 4) = "Word"
            Case "xls", "xlsx", "xlsm"
                Cells(n, 4) = "Excel"
            Case "ppt", "pptx", "pptm"
                Cells(n, 4) = "PowerPoint"
            Case "pdf"
                Cells(n, 4) = "PDF"
            Case "zip"
                Cells(n, 4) = "ZIP"
            Case Else
                Cells(n, 4) = "その他"
        End Select
    Next
    
    '再帰
    For Each fd In Fso.GetFolder(strPath).SubFolders
        Call MakeFileList(fd.Path)
    Next
    
End Sub

'---------------------------------------------
'パスワード有無の判定（Office,PDF)
'---------------------------------------------
Function IsPass(Path As String) As String
 
    If Dir(Path) = "" Then
        IsPass = "ファイルなし"
        Exit Function
    End If
    
    Dim buf As String, kks As String
    kks = LCase(Replace(Right(Path, 4), ".", ""))   '拡張子
    IsPass = "なし"
    
    Select Case kks
        Case "xlsx", "xlsm", "docx", "docm", "pptx", "pptm", "ppts", "pdf" 'office2007以降とpdf
            On Error Resume Next
            With CreateObject("Scripting.FileSystemObject").GetFile(Path).OpenAsTextStream
                buf = .ReadAll
                .Close
            End With
            On Error GoTo 0
            If InStr(buf, "Encrypt") > 0 Or InStr(buf, "encrypt") > 0 Then IsPass = "有"
        Case "xls", "doc", "ppt"  'office2003以前
            With CreateObject("ADODB.Stream")
                .Charset = "SJIS"
                .Open
                .LoadFromFile Path
                buf = .ReadText
                .Close
                buf = Replace(buf, Chr(0), " ") '何故か半角スペースがChr(0)で表記されている
                If InStr(buf, "C r y p t o g r a p h i c") > 0 Then
                   IsPass = "有"
                End If
            End With
        Case "zip"
            Dim fn, Arr() As Byte
            Dim i As Long, fsize
            fn = FreeFile
            Open Path For Binary Access Read As #fn
            fsize = LOF(fn)
            ReDim Arr(fsize)
            'ZIPファイルをバイナリで1バイトずつ読み込み、ファイル情報があれば判定
            For i = 0 To fsize - 21
                Get #fn, i + 1, Arr(i + 20)
                'Local file headerシグネチャを検索
                If Arr(i) & Arr(i + 1) & Arr(i + 2) & Arr(i + 3) = "807534" Then
                    'ファイルサイズを判定（0000の場合は無視）
                    If Arr(i + 18) & Arr(i + 19) & Arr(i + 20) & Arr(i + 21) <> "0000" Then
                        '暗号化ビットでパスワードの有無を判定
                        If Arr(i + 6) Mod 2 = 1 Then
                           IsPass = "有"
                        End If
                        Close #fn
                        Exit Function
                    End If
                End If
            Next
            IsPass = "実ファイルなし"
            Close #fn
        Case Else
            IsPass = kks & "：対象外"
    End Select
    
End Function