冗長化削除

コードの簡略化と高速化のために、ファイル形式の分別を省略し、パスワード有無のチェックを行うための条件や処理をより効率的に整理しました。以下は、指定された指示に従って修正されたコードです。

Option Explicit

' メイン処理
Sub Main()
    Dim Path As String
    Cells.ClearContents
    
    ' フォルダ選択ダイアログを表示
    Path = SelectFolder(ThisWorkbook.Path)
    If Path = "" Then Exit Sub
    
    ' ヘッダーの設定
    SetHeaders
    
    ' ファイル一覧作成とパスワードチェック
    MakeFileList Path
    MsgBox n - 1 & "件のチェックが完了しました"
End Sub

' フォルダ選択ダイアログ
Function SelectFolder(initialPath As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = initialPath
        If .Show Then
            SelectFolder = .SelectedItems(1)
        Else
            MsgBox "フォルダーが選択されなかったので終了します"
            SelectFolder = ""
        End If
    End With
End Function

' ヘッダーの設定
Sub SetHeaders()
    Cells(2, 1) = "No"
    Cells(2, 2) = "ファイル名"
    Cells(2, 3) = "パスワード"
    n = 2
End Sub

' ファイル一覧作成とパスワードチェック
Sub MakeFileList(strPath As String)
    Dim fso As Object, folder As Object, file As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(strPath)
    
    ' フォルダ内の全ファイルを処理
    For Each file In folder.Files
        n = n + 1
        Cells(n, 1) = n - 2
        Cells(n, 2) = file.Name
        Cells(n, 3) = CheckPassword(file.Path)
    Next
    
    ' サブフォルダ内のファイルを再帰的に処理
    For Each folder In folder.SubFolders
        MakeFileList folder.Path
    Next
End Sub

' パスワード有無の確認
Function CheckPassword(filePath As String) As String
    Dim buf As String, ext As String
    ext = LCase(Right(filePath, 4))
    CheckPassword = "なし"
    
    If ext = ".zip" Then
        CheckPassword = CheckZipPassword(filePath)
    Else
        buf = ReadFileContent(filePath)
        If InStr(buf, "Encrypt") > 0 Or InStr(buf, "C r y p t o g r a p h i c") > 0 Then
            CheckPassword = "有"
        End If
    End If
End Function

' ファイル内容の読み込み
Function ReadFileContent(filePath As String) As String
    On Error Resume Next
    With CreateObject("ADODB.Stream")
        .Charset = "SJIS"
        .Open
        .LoadFromFile filePath
        ReadFileContent = Replace(.ReadText, Chr(0), " ")
        .Close
    End With
    On Error GoTo 0
End Function

' ZIPファイルのパスワード確認
Function CheckZipPassword(filePath As String) As String
    Dim fn As Integer, arr() As Byte, i As Long, fileSize As Long
    fn = FreeFile
    Open filePath For Binary Access Read As #fn 
    fileSize = LOF(fn)
    ReDim arr(fileSize)
    Get #fn , , arr
    Close #fn 
    
    For i = 0 To fileSize - 22
        If arr(i) & arr(i + 1) & arr(i + 2) & arr(i + 3) = "807534" Then
            If arr(i + 6) Mod 2 = 1 Then
                CheckZipPassword = "有"
                Exit Function
            End If
        End If
    Next
    CheckZipPassword = "なし"
End Function

この修正されたコードでは、ファイル形式の分別を削除し、パスワードチェックの処理をよりシンプルにしました。また、冗長な処理を削除することで、コードの実行速度も向上させています。