LoginSignup
4
14

More than 5 years have passed since last update.

@irohamaru(irohamaru)

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

Last updated at Posted at 2019-04-12

使い方

「チェック開始」ボタン押下で所定のフォルダ配下の各ファイルに対して、パスワード有無を判定します。
チェック対象ファイルは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
4
14
2

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
4
14