トップ　>　備忘録　>　フォルダのパス取得・存在確認

Sub Sample_Directory()
    Dim strDirPath As String
    Dim strExistDir As String
    strDirPath = Search_Directory()
    If Len(strDirPath) = 0 Then Exit Sub
    strExistDir = IsExistence_Directory(strDirPath)
    If Len(strExistDir) = 0 Then Exit Sub
    MsgBox "選択したフォルダは[" & strExistDir & "]"
End Sub

Function Search_Directory() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then Search_Directory = .SelectedItems(1)
    End With
End Function

Function IsExistence_Directory(ByVal DirPath As String) As String
    IsExistence_Directory = Dir(DirPath, vbDirectory)
End Function

Sub All_Books_Protect()
    Dim strDirPath As String
    Dim strExistDir As String
    strDirPath = Search_Directory()
    If Len(strDirPath) = 0 Then Exit Sub
    strExistDir = IsExistence_Directory(strDirPath)
    If Len(strExistDir) = 0 Then Exit Sub
    Call Search_Books(strDirPath)
End Sub

Private Function Search_Directory() As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = True Then Search_Directory = .SelectedItems(1)
    End With
End Function

Private Function IsExistence_Directory(ByVal DirPath As String) As String
    IsExistence_Directory = Dir(DirPath, vbDirectory)
End Function

Private Sub Search_Books(ByVal strPath As String)
    Dim strTarget As String
    Dim strDirPath As String
    With Application
        strPath = strPath & .PathSeparator
        strTarget = Dir(strPath & "*.xls?")
        If strTarget = "" Then Exit Sub
        .ScreenUpdating = False
        Do
            With Workbooks.Open(strPath & strTarget)
                If SheetsProtect() Then .Save
                .Close
            End With
            strTarget = Dir()
        Loop Until strTarget = ""
        .ScreenUpdating = True
        strTarget = Dir("")
    End With
End Sub

Private Function SheetsProtect() As Boolean
    Dim objWS As Worksheet
    With Application.ActiveWorkbook
        For Each objWS In .Worksheets
            With objWS
                If Not .ProtectContents Then
                    .Protect Password:="pass"
                ' Else
                    ' .Unprotect Password:="pass"
                End If
            End With
        Next
    End With
    SheetsProtect = True
End Function

Sub UseFileDialogOpen()
    Dim lngCount As Long
    ' ファイル ダイアログを開きます。
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True 'ファイルの複数選択を可能にする
        .Show
        ' 選択された各ファイルのパスを表示します。
        For lngCount = 1 To .SelectedItems.Count
            MsgBox .SelectedItems(lngCount)
        Next
    End With
End Sub