Excel ファイルパス、フォルダパスを選択しセルに格納する参照ボタン

Excelでツールを作成する時、必ずと言っていい程必要になるフォルダ選択ダイアログとファイル選択ダイアログ。
存在チェックとかダイアログ初期値設定とか意外と面倒なのでメモ。

Excelシート設定

• セル名を指定する。
  例)cellFolderPath, cellFilePath
  
  

• 参照ボタンの設定は下記のような感じで
  

VBE参照設定

• 「Microsoft Scripting Runtime」を参照設定する。
  
  　選択肢にない場合は「参照」ボタンから
  
  　C:\Windows\System32\scrrun.dll
  
  を選択する。
  
  

フォルダ選択ダイアログマクロ

• ざっくり仕様
• セルにパスがある場合、参照ぼたん押下時はその場所を開く。
• セルにパスがない場合、または、存在しないパスの場合はブックの場所を開く。

• ソース

フォルダ選択Dialog.vba

' 検索対象フォルダの参照ボタンのクリックイベント
Private Sub btnChoiceFolder_Click()
    Dim objFS           As New FileSystemObject
    Dim strPath         As String
    Dim ofdFolderDlg    As Office.FileDialog

    strPath = Range("cellFolderPath").Value

    ' 初期フォルダの設定
    If Len(strPath) > 0 Then
        ' 末尾の"\"削除
        If Right(strPath, 1) = "\" Then
            strPath = Left(strPath, Len(strPath) - 1)
        End If

        ' フォルダ存在チェック
        If Not objFS.FolderExists(strPath) Then
            strPath = ThisWorkbook.Path
        End If
        Set objFS = Nothing
    Else
        strPath = ThisWorkbook.Path
    End If

    ' フォルダ選択ダイアログ設定
    Set ofdFolderDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With ofdFolderDlg
        ' 表示するアイコンの大きさを指定
        .InitialView = msoFileDialogViewDetails
        ' フォルダ初期位置
        .InitialFileName = strPath & "\"
        ' 複数選択不可
        .AllowMultiSelect = False
    End With

    ' フォルダ選択ダイアログ表示
    If ofdFolderDlg.Show() = -1 Then
        ' フォルダパス設定
        Range("cellFolderPath").Value = ofdFolderDlg.SelectedItems(1)
    End If

    Set ofdFolderDlg = Nothing
    Exit Sub
End Sub

• 結果
  
  こんな感じ
  

ファイル選択ダイアログマクロ

• ざっくり仕様
• セルにファイルパスがある場合、参照ぼたん押下時はその場所を開く。ファイル名も選択状態にする。
• セルにパスがない場合、または、存在しないパスの場合はブックの場所を開く。ファイル名はなしの状態。
• セルにフォルダパスが指定してある場合、そのフォルダを開く。ファイル名はなしの状態。

• ソース

ファイル選択Dialog.vba

Private Sub btnChoiceFile_Click()
    Dim objFS           As New FileSystemObject
    Dim strPath         As String
    Dim strFile         As String
    Dim strFolder       As String
    Dim ofdFolderDlg    As Office.FileDialog

    strPath = Range("cellFilePath").Value

    ' 初期パスの設定
    If Len(strPath) > 0 Then
        ' 末尾の"\"削除
        If Right(strPath, 1) = "\" Then
            strPath = Left(strPath, Len(strPath) - 1)
        End If

        ' ファイルが存在
        If objFS.FileExists(strPath) Then
            ' ファイル名のみ取得
            strFile = objFS.GetFileName(strPath)
            ' フォルダパスのみ取得
            strFolder = objFS.GetParentFolderName(strPath)
        ' ファイルが存在しない
        Else
            ' フォルダが存在
            If objFS.FolderExists(strPath) Then
                strFile = ""
                strFolder = strPath
            ' フォルダが存在しない
            Else
                ' ファイル名のみ取得
                strFile = objFS.GetFileName(strPath)
                ' 親フォルダを取得
                strFolder = objFS.GetParentFolderName(strPath)
                ' 親フォルダが存在しない
                If Not objFS.FolderExists(strFolder) Then
                    strFolder = ThisWorkbook.Path
                End If
            End If
        End If
        Set objFS = Nothing
    Else
        strFolder = ThisWorkbook.Path
        strFile = ""
    End If

    ' ファイル選択ダイアログ設定
    Set ofdFileDlg = Application.FileDialog(msoFileDialogFilePicker)
    With ofdFileDlg
        .ButtonName = "選択"
        '「ファイルの種類」をクリア
        .Filters.Clear
        '「ファイルの種類」を登録
        .Filters.Add "CSVファイル", "*.?sv", 1
        .Filters.Add "全ファイル", "*.*", 2

        ' 初期フォルダ
        .InitialFileName = strFolder & "\" & strFile
        ' 複数選択不可
        .AllowMultiSelect = False
        '表示するアイコンの大きさを指定
        .InitialView = msoFileDialogViewDetails
    End With

    ' フォルダ選択ダイアログ表示
    If ofdFileDlg.Show() = -1 Then
        ' フォルダパス設定
        Range("cellFilePath").Value = ofdFileDlg.SelectedItems(1)
    End If

    Set ofdFileDlg = Nothing
    Exit Sub
End Sub

• 結果
  
  こんな感じ