Option Explicit

Public Const CNST_STR_DESKTOP   As String = "Desktop"

Public Function OpenFolderDialog() As String
'-------------------------------------------------------------------------------
'概要   :フォルダの参照ダイアログ呼び出し
'機能名 :OpenFolderDialog
'引数   :なし
'戻り値 :フォルダのパス(キャンセル時は空文字("")を返す)
'備考   :
'-------------------------------------------------------------------------------
    Dim Shell               'Shell.Application
    Dim ShellPath           'BrowseForFolder 用
    Dim objWShell As Object 'WScript.Shell
    Dim s_DesktopPath As String
    Dim s_WkPath As String
On Error GoTo ErrTrap
    '-----------------------------
    '初期化
    '-----------------------------
    s_WkPath = ""
    OpenFolderDialog = ""

    '-----------------------------
    'デスクトップのパスを取得
    '-----------------------------
    Set objWShell = CreateObject("WScript.Shell")
    s_DesktopPath = objWShell.SpecialFolders(CNST_STR_DESKTOP)
    Set objWShell = Nothing
    
    '-----------------------------
    'フォルダの参照のダイアログを開く
    '-----------------------------
    Set Shell = CreateObject("Shell.Application")
    Set ShellPath = Shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, s_DesktopPath & "\")

    If Not ShellPath Is Nothing Then
        
        Select Case ShellPath
            Case "デスクトップ"
                'Shell.BrowseForFolder でデスクトップを選択した場合
                ' .Items.Item.Path ではErr.Number = 91 が発生するため
                s_WkPath = s_DesktopPath
            Case Else
                s_WkPath = ShellPath.Items.Item.Path
        End Select
        
    End If
    
    '-----------------------------
    '終了処理
    '-----------------------------
    GoSub FINALLY
    
    OpenFolderDialog = s_WkPath
    
    Exit Function
FINALLY:
    '-----------------------------
    '終了処理
    '-----------------------------
    Set objWShell = Nothing
    Set ShellPath = Nothing
    Set Shell = Nothing
    Return
ErrTrap:
    GoSub FINALLY
    Call Err.Raise(Err.Number, Err.Source, "→[OpenFolderDialog]：" & Err.Description, Err.HelpFile, Err.HelpContext)
End Function

Private Sub CommandButton1_Click()
    Dim s_FolderPath As String
    Dim s_Name As String
On Error GoTo ErrTrap

    s_FolderPath = OpenFolderDialog
    
    If s_FolderPath = "" Then
        'フォルダが選択されなかった場合
        MsgBox "フォルダが選択されませんでした"
    Else
        'フォルダが選択された場合
        MsgBox s_FolderPath & " フォルダが選択されました"
    End If
        
    
    Exit Sub
ErrTrap:
    MsgBox Err.Description, vbCritical, "エラー発生"
End Sub