今まで、ZIPファイルやOffice、PDFファイルのパスワード有無を高速にチェックする仕組みとコードを紹介してきました。いずれも公開時点でネット上で見つけることができず、苦心かつ楽しみつつ編み出したロジックなので、それらを埋め込み、実際に使えるxlsmワークブックを公開したら、読んでいただいた方のお役に立てるのではないかと思い、マクロ付きワークブックを掲載します。
セキュリティのエラーが出て、マクロ有効にできない場合は、まずいったんExcelを終了します。Explore画面上で本ファイルを右クリックしプロパティをクリック、表示されるダイアログの全般タグの一番下、セキュリティの許可するチェックボックスをオンにしてください。OKしてダイアログを閉じ、改めて本ワークブックを開くと、警告は消え、マクロを有効化して使用することができるようになると思います。
コード全行は次の通りで、メイン、ファイル一覧作成、パスワード有無判定関数の3つのプロシージャで構成されています。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 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 |
実行すると、フォルダーを選択するダイアログが開きます。選択したフォルダー内にあるファイルを、サブフォルダーも含めて一覧化し、Excel、Word、PowePoint、PDF、ZIPの場合は、それぞれパスワードが設定されているかを高速にチェックし、一覧化します。
勤務先のガバナンス関係、しっかりとファイルにパスワードが設定されているか一括して確認したい等のビジネスシーンで活用いただけるかと思っています。それではよいVBAライフを。
コメント