指定したフォルダー内にあるOffice、PDF、ZIPのパスワード有無を高速に一括確認するマクロ

今まで、ZIPファイルやOffice、PDFファイルのパスワード有無を高速にチェックする仕組みとコードを紹介してきました。いずれも公開時点でネット上で見つけることができず、苦心かつ楽しみつつ編み出したロジックなので、それらを埋め込み、実際に使えるxlsmワークブックを公開したら、読んでいただいた方のお役に立てるのではないかと思い、マクロ付きワークブックを掲載します。

ワークブックをダウンロード(29KB)

セキュリティのエラーが出て、マクロ有効にできない場合は、まずいったんExcelを終了します。Explore画面上で本ファイルを右クリックしプロパティをクリック、表示されるダイアログの全般タグの一番下、セキュリティの許可するチェックボックスをオンにしてください。OKしてダイアログを閉じ、改めて本ワークブックを開くと、警告は消え、マクロを有効化して使用することができるようになると思います。

コード全行は次の通りで、メイン、ファイル一覧作成、パスワード有無判定関数の3つのプロシージャで構成されています。

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) = "フォルダ"
    Cells(2, 6) = "更新日"
    Cells(2, 7) = "サイズ(KB)"
    Cells(2, 8) = "パスワード"
    Cells(2, 9) = "処理時間（秒）"
    n = 2
    'Application.ScreenUpdating = False
    Call MakeFileList(Path)
    'Application.ScreenUpdating = True
    DoEvents
    
    'パスワードチェック
    Dim r As Long, Start
    r = 2
    Do
        r = r + 1
        If Cells(r, 1) = "" Then Exit Do
        Cells(r, 8).Select
        Start = Timer
        Cells(r, 8) = IsPass(Cells(r, 5) & "\" & Cells(r, 2))
        Cells(r, 9) = Timer - Start
    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)
        Cells(n, 4) = f.Type
        Cells(n, 5) = f.ParentFolder
        Cells(n, 6) = f.DateLastModified
        Cells(n, 7) = Round(f.Size / 1024, 0)
    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

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

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) = "フォルダ"

Cells(2, 6) = "更新日"

Cells(2, 7) = "サイズ(KB)"

Cells(2, 8) = "パスワード"

Cells(2, 9) = "処理時間（秒）"

n = 2

'Application.ScreenUpdating = False

Call MakeFileList(Path)

'Application.ScreenUpdating = True

DoEvents

'パスワードチェック

Dim r As Long, Start

r = 2

r = r + 1

If Cells(r, 1) = "" Then Exit Do

Cells(r, 8).Select

Start = Timer

Cells(r, 8) = IsPass(Cells(r, 5) & "\" & Cells(r, 2))

Cells(r, 9) = Timer - Start

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)

Cells(n, 4) = f.Type

Cells(n, 5) = f.ParentFolder

Cells(n, 6) = f.DateLastModified

Cells(n, 7) = Round(f.Size / 1024, 0)

'再帰

For Each fd In Fso.GetFolder(strPath).SubFolders

Call MakeFileList(fd.Path)

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

IsPass = "実ファイルなし"

Close #fn

Case Else

IsPass = kks & "：対象外"

End Select

End Function

実行すると、フォルダーを選択するダイアログが開きます。選択したフォルダー内にあるファイルを、サブフォルダーも含めて一覧化し、Excel、Word、PowePoint、PDF、ZIPの場合は、それぞれパスワードが設定されているかを高速にチェックし、一覧化します。

勤務先のガバナンス関係、しっかりとファイルにパスワードが設定されているか一括して確認したい等のビジネスシーンで活用いただけるかと思っています。それではよいVBAライフを。