【VBA】パスワード有無チェックツール


使い方

「チェック開始」ボタン押下で所定のフォルダ配下の各ファイルに対して、パスワード有無を判定します。

チェック対象ファイルはxls*, doc*, ppt*, zip, pdfです。

pdfに関しては、手動でファイル名押下して、直接ファイルを開いて確認する仕様としています。

image.png


注意

Cドライブ直下など、ファイルが大量にある場所を指定しての実行は危険です><

できれば細かくフォルダを分けてチェックしていってください。

Office2010で実行すると、パスワードなしのExcelファイルをチェックした際にExcelプロセスが残ってしまう事象が起こります。Office2016での実行を推奨します。

プロセスが残ってしまった場合は、コマンドプロンプトで↓を実行してExcelプロセスを切ってください。

taskkill /im EXCEL.EXE /F


ソース

「チェック開始」ボタンにpassCheck()を登録すること。

'=======================================================================

'
' File Name : ファイルパスワードチェック.xlsm
' Creation Date : 2019/04/03
'
' Copyright (c) 2019 irohamaru. All rights reserved.
'
' This source code or any portion thereof must not be
' reproduced or used in any manner whatsoever.
'
'=======================================================================

Option Explicit

Const MAINSHEETNAME As String = "メイン"
Const SEARCHCELLRNG As String = "H3"
Const HEADERROW As Integer = 5
Const FOLDERCOL As String = "H"
Const FILENMCOL As String = "I"
Const RESULTCOL As String = "J"
Const CHECK_OK As String = "パスワード保護OK"
Const CHECK_NG As String = "パスワード保護NG"
Const NO_CHECK As String = "チェック対象外"
Const CHECK_ERROR As String = "チェックエラー"
Const MSG_EXCEL As String = "入力したパスワードが間違っています。"
Const MSG_PPT As String = "読み取りパスワードをもう一度入力してください"
Const MSG_WORD As String = "パスワードが正しくありません。"
Const MSG_PDF As String = "パスワードが正しくありません。"
Const MSG_ZIP As String = "入力したパスワードが間違っています。"

' パスワードチェック
Sub passCheck()

Dim mainSheet As Worksheet
Set mainSheet = Worksheets(MAINSHEETNAME)
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")

' チェック対象フォルダパス取得
Dim folderPath As String, folderExist As String

folderPath = mainSheet.Range(SEARCHCELLRNG).Value
folderExist = Dir(folderPath, vbDirectory)

' フォルダ存在チェック
If folderExist = "" Then
MsgBox "チェック対象のフォルダが存在しません。" & vbCrLf & _
"処理を終了します。", vbExclamation
GoTo passCheckErr1
End If

' ファイル一覧初期化
Call listClear(mainSheet)
' ファイル一覧取得
Call FileSearch(objFSO.GetFolder(folderPath))

' 最下行取得
Dim maxRow As Integer
If mainSheet.Range(FOLDERCOL & (HEADERROW + 1)).Value = "" Then
MsgBox "ファイルなしエラー"
GoTo passCheckErr1
Else
maxRow = mainSheet.Range(FOLDERCOL & HEADERROW).End(xlDown).Row
End If

' パスワードチェック
Dim i As Integer
For i = HEADERROW + 1 To maxRow
' チェック結果格納用
' 1:チェックOK, 2:チェックNG, 3:チェック対象外ファイル
Dim checkResult As Integer

With mainSheet
' ファイルパス取得
Dim f As String
f = .Range(FOLDERCOL & i).Value & "\" & .Range(FILENMCOL & i).Value

' パスワードチェック
checkResult = IsLockedFile(f)

' 結果記入
Select Case checkResult
Case 1
.Range(RESULTCOL & i).Value = CHECK_OK
Case 2
.Range(RESULTCOL & i).Value = CHECK_NG
.Range(RESULTCOL & i).Interior.Color = RGB(255, 0, 0)
Case 3
.Range(RESULTCOL & i).Value = NO_CHECK
.Range(RESULTCOL & i).Interior.Color = RGB(255, 255, 0)
Case Else
.Range(RESULTCOL & i).Value = CHECK_ERROR
.Range(RESULTCOL & i).Interior.Color = RGB(243, 152, 0)
End Select

End With

Next

passCheckErr1:
Set mainSheet = Nothing
Set objFSO = Nothing

MsgBox "パスワードチェックが完了しました。"

End Sub

' ファイル一覧取得&記入
Sub FileSearch(ByVal folderPath As String)

Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim mainSheet As Worksheet
Set mainSheet = Worksheets(MAINSHEETNAME)

Dim objFolder, objSubFolders As Object
Set objFolder = objFSO.GetFolder(folderPath)
Set objSubFolders = objFolder.SubFolders

On Error Resume Next

Dim sf As Object
For Each sf In objSubFolders
FileSearch sf
Next
Set sf = Nothing

Dim f As Object
Dim rowNum, maxRow As Integer

' 最下行取得
If mainSheet.Range(FOLDERCOL & (HEADERROW + 1)).Value = "" Then
maxRow = HEADERROW
Else
maxRow = mainSheet.Range(FOLDERCOL & HEADERROW).End(xlDown).Row
End If
rowNum = maxRow + 1

For Each f In objFolder.Files
With mainSheet
.Hyperlinks.Add Anchor:=.Range(FOLDERCOL & rowNum), _
Address:=objFSO.GetParentFolderName(f.Path), _
TextToDisplay:=objFSO.GetParentFolderName(f.Path)
.Hyperlinks.Add Anchor:=.Range(FILENMCOL & rowNum), _
Address:=f.Path, _
TextToDisplay:=objFSO.GetFileName(f.Path)
End With
rowNum = rowNum + 1
Next
Set f = Nothing

Set objSubFolders = Nothing
Set objFolder = Nothing
Set mainSheet = Nothing
Set objFSO = Nothing

End Sub

Private Sub listClear(ByVal sh As Worksheet)

' セル一覧の最下行を取得し、セルをクリア
Dim maxRow As Integer

maxRow = sh.Range(FOLDERCOL & HEADERROW).End(xlDown).Row
sh.Range(FOLDERCOL & (HEADERROW + 1) & ":" & RESULTCOL & maxRow).Clear
sh.Range(FOLDERCOL & (HEADERROW + 1) & ":" & RESULTCOL & maxRow).Font.Name = "メイリオ"
sh.Range(FOLDERCOL & (HEADERROW + 1) & ":" & RESULTCOL & maxRow).Font.Size = 10

End Sub

'パスワード保護されているブックで TRUE を返す
Function IsLockedFile(ByVal tgtPath As String) As Integer

Dim errDescription As String
Dim errNum As Long

Dim objFSO, objShell As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")

Dim cnsMsg As String, ext As String, skipFlg As Boolean: skipFlg = False
ext = objFSO.GetExtensionName(tgtPath)

On Error Resume Next

Select Case ext
Case "xls", "xlsx", "xlsm"
cnsMsg = MSG_EXCEL

Dim objExcel, wb As Object
Set objExcel = CreateObject("Excel.Application")
Set wb = objExcel.Workbooks.Open(tgtPath, Password:=vbNullString)

errDescription = Err.Description
errNum = Err.Number

objExcel.DisplayAlart = False
wb.Close (False)
objExcel.DisplayAlart = True

Set wb = Nothing
objExcel.Quit
Set objExcel = Nothing

Case "ppt", "pptx", "pptm"
cnsMsg = MSG_PPT

Dim p, ppt As Object
Set p = CreateObject("PowerPoint.Application")
Set ppt = p.Presentations.Open(tgtPath & "::unknown", WithWindow:=msoFalse)

errDescription = Err.Description
errNum = Err.Number

ppt.Close
Set ppt = Nothing
p.Quit
Set p = Nothing

Case "doc", "docx", "docm"
cnsMsg = MSG_WORD

Dim wd, doc As Object
Set wd = CreateObject("Word.Application")
Set doc = wd.Documents.Open(tgtPath, passworddocument:="unknown", Visible:=False)

errDescription = Err.Description
errNum = Err.Number

doc.Close
Set doc = Nothing
wd.Quit
Set wd = Nothing

Case "pdf"
' Excelのハイパーリンク押下⇒開いて確認で回避?

Case "zip"
Dim folderPath As String
folderPath = objFSO.GetParentFolderName(tgtPath)

' 作業用フォルダ作成
Dim mkDirPath As String
Dim cnt As Integer: cnt = 0
While cnt < 10
mkDirPath = folderPath & "\" & "workfolder_" & Rnd
If Dir(mkDirPath, vbDirectory) = "" Then
MkDir (mkDirPath)
cnt = 10
End If
Wend

Dim objZip As Object
Dim result As Integer
'なぜか二重カッコが必要
'進捗ダイアログを表示しない
objShell.Namespace((mkDirPath)).CopyHere objShell.Namespace((tgtPath)).Items, &H4 + &H40 + &H400

' 一時フォルダ内のファイル数カウント
Dim buf As String, fileCount As Long
buf = Dir(mkDirPath & "\*")
Do While buf <> ""
fileCount = fileCount + 1
buf = Dir()
Loop

Select Case fileCount
Case Is > 0
' パスワードチェックNG
IsLockedFile = 2
Case Is = 0
' パスワードチェックOK
IsLockedFile = 1
Case Else
' パスワードチェックエラー
IsLockedFile = 4
End Select

' 一時フォルダ削除
objFSO.DeleteFolder (mkDirPath)

skipFlg = True

Case Else
' チェック対象外ファイルの場合

End Select

On Error GoTo 0

' zipファイルチェック以外の場合のみ実行
If skipFlg = False Then
' 対象外フォイルの場合
If cnsMsg = "" Then
IsLockedFile = 3
GoTo IsLockedFileClose
End If

If InStr(errDescription, cnsMsg) > 0 Then
' パスワードチェックOK
IsLockedFile = 1

ElseIf Err.Number = 0 Then

' パスワードチェックNG
IsLockedFile = 2

Else
Err.Raise errNum, , errDescription
End If
End If

IsLockedFileClose:
Set objShell = Nothing
Set objFSO = Nothing

End Function