編集履歴

質問編集履歴

コードを記載させていただきました。参照させて頂いたページは補足情報欄に記載しています

2021/10/04 08:58

投稿

takahiro_y2j

スコア0

test CHANGED Viewed

File without changes

test CHANGED Viewed

@@ -30,26 +30,646 @@
+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 & "*", vbDirectory)
+Do While buf <> ""
+If buf <> "." And buf <> ".." Then
+fileCount = fileCount + 1
+End If
+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
+### 補足情報（FW/ツールのバージョンなど）
+参照させていただいたのは下記サイト様です。
 https://qiita.com/irohamaru/items/6021327a5c39422fa2f4
 https://teratail.com/questions/240188
-```
-### 補足情報（FW/ツールのバージョンなど）
-ここにより詳