高速でOfficeファイルの読み取り専用パスワード有無とPDFファイルのパスワード有無を判定するマクロのVBAコードです。
|
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 |
'--------------------------------------------- 'パスワード有無の高速判定（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 Else IsPass = kks & "：対象外" End Select End Function |
ファイルのパスを渡すと、読み取り専用パスワードの有無、PDFの場合はパスワードの有無が返ってきます。前回のエントリー
Officeファイルに読み取り専用パスワードが設定されているかどうか判定する場合、この前回のやり方が一般的だと思うのですが、大量の処理を行う際や巨大なファイルがある場合は、非常に時間がかかってしまいます。何か良い方法がないか、もっと簡単に判定できるのではないかと、ExcelやWord、PowerPoint、そしてPDFも、調べてみたんですよね。
いやはや、簡単でした。単純にテキストファイルとして開くと「Encrypt」もしくは「encrypt」の文字列が存在する！
色んなファイルのパターンを見てみたんですが、調べた限り問題なさそうで、それを判定している部分がこちら。
|
1 2 3 4 5 6 7 8 |
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 = "有" |
ところが、ここで問題が。どうもOffice2003以前の、そう、懐かしのxlsやdoc形式のファイルには、この法則が当てはまらず、Encryptやencryptのような、それらしい文字列がなかったのです。FSO（FileSystemObject）は文字コードUnicode（UTF-16）でファイルを開くのですが、ひょっとしたら別の文字コードに変更して開いてみてはどうかと思いつき、そして、S-JISで開くことで、それらしい文字列を見つけることができました！「C r y p t o g r a p h i c」という文字列です。よって、Office2003以前のファイルの場合は、FSOではなく、ADODB.Streamで開くことで解決の道筋が見えたわけです。
が、しかし、この後が、さらに大変でした。やっとの思いで見つけた「C r y p t o g r a p h i c」文字列、S-JISで開いたテキストエディターで見ると居ます。確かに居るのですが、でも、instr関数で探しても一致しない。つまり、居ないのです。
これはハマりました。居るのに居ないという不可思議な現象、何度もくじけそうになりましたが、一文字ずつ文字コードを追っていくやり方が奏功、ようやく原因が判明しました。半角スペースに見えたものは、半角スペースではなく、なんと文字コード「0」だったのです。これにて解決、文字コード「0」を半角スペースに変換してからinstr関数で探すことで、正しく判定できるようになりました。まあ、こうやって書くと簡単な感じですが、ここに至るまで涙なくなしては語れない、そんなコードがこの部分です。
|
1 2 3 4 5 6 7 8 9 10 11 12 |
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 |
ようやく完成した【高速版】、活用いただけたら嬉しいです。それでは、よいVBAライフを。
コメント
コメント失礼します。
当方の環境で、うまくいかないケースが何点かあったためご参考までに共有させていただきます。
・読み取り専用ファイルの判定が出来ない。
・SHARPのスキャナーで作成されたPDFが、誤って鍵ありと判定される。
ex) PDF-1.4 Sharp Scanned Image PDF
Sharp Non-Encryption
→Non-Encryptionが原因
・.xlsx形式でもJISで
E n c r y p t e d p a c k a g e
の表記があるものがあり
鍵はかかっているが、鍵なしと判定される。
→原因特定中
また何かわかれば書き込まさせていただきます。
dさん、コメントありがとうございました。
色んなケースがあるのですね。
読み取り専用ファイルは、想定外でした。調べてみます。
＞→Non-Encryptionが原因
これは、例外判定を入れれば対応できそうです。
＞・.xlsx形式でもJISで
＞E n c r y p t e d p a c k a g e
そんなファイルがあるのですね。
これも、文字列が特殊なので、条件に入れれば、対応できそうです。
続報をお待ちしております！