#使い方
「チェック開始」ボタン押下で所定のフォルダ配下の各ファイルに対して、パスワード有無を判定します。
チェック対象ファイルはxls*, doc*, ppt*, zip, pdfです。
pdfに関しては、手動でファイル名押下して、直接ファイルを開いて確認する仕様としています。
#注意
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