リファクタリング

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) = "拡張子"
    Cells(2, 4) = "ファイル形式"
    Cells(2, 5) = "パスワード"
    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) = fso.GetExtensionName(file)
        Cells(n, 4) = GetFileCategory(fso.GetExtensionName(file))
        Cells(n, 5) = CheckPassword(file.Path)
    Next
    
    ' サブフォルダ内のファイルを再帰的に処理
    For Each folder In folder.SubFolders
        MakeFileList folder.Path
    Next
End Sub

' ファイル形式の取得
Function GetFileCategory(extension As String) As String
    Select Case LCase(extension)
        Case "doc", "docx", "docm": GetFileCategory = "Word"
        Case "xls", "xlsx", "xlsm": GetFileCategory = "Excel"
        Case "ppt", "pptx", "pptm": GetFileCategory = "PowerPoint"
        Case "pdf": GetFileCategory = "PDF"
        Case "zip": GetFileCategory = "ZIP"
        Case Else: GetFileCategory = "その他"
    End Select
End Function

' パスワード有無の確認
Function CheckPassword(filePath As String) As String
    Dim buf As String, ext As String
    ext = LCase(Right(filePath, 4))
    CheckPassword = "なし"
    
    Select Case ext
        Case ".zip"
            CheckPassword = CheckZipPassword(filePath)
        Case ".xls", "xlsx", "doc", "docx", "ppt", "pptx", ".pdf"
            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
        Case Else
            CheckPassword = ext & "：対象外"
    End Select
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

主な変更点:

1. サブ関数の作成: `SelectFolder`, `SetHeaders`, `GetFileCategory`, `CheckPassword`, `ReadFileContent`, `CheckZipPassword`といったサブ関数を作成し、各処理を明確に分けました。

2. コメントの追加: 各関数や処理の目的をコメントで説明し、理解しやすいコードにしました。

3. コードの簡略化: 無駄な処理を削減し、コードの読みやすさと保守性を向上させました。