ダウンロード(フォルダの参照)

「フォルダ参照」のダイアログを汎用関数化したものです。

Application.FileDialogを用いた方法です。

サンプルExcelブック「MsoFolderPicker2.xlsm」の方を起動させると動作確認ができます。

(この画像をクリックすると、ダウンロードができます。)
「modFolderPicker2.bas」が「フォルダの参照」のメインモジュールです。組み込みの際はこれをプロジェクトにインポートさせて下さい。「MsoFolderPicker2.xlsm」には「modFolderPicker2.bas」が組み込まれた状態になっています。

左上の「フォルダの参照」ボタンをクリックすると、
フォルダの参照(組み込みモジュール)

このようにフォルダ名を取得するためのダイアログが表示されます。
サンプルは「選択」をクリックした時に取得したフォルダのフルパス名をメッセージボックスに表示させるだけになっています。このサンプル画像はWindows10での画像です。Windowsの世代によって左ペインの動作が異なります。

今回、汎用関数化したプロシージャは「FolderDialog」と名付けました。
呼び出しサンプルのコード（Module1）は以下の通りです。
上の画像の7つのボタンから呼び出されるプロシージャが並んでいます。


'***************************************************************************************************
'   フォルダ参照のダイアログ処理(シートからの呼び出し部分)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'14/04/14(1.00)新規作成
'19/10/28(1.10)Declare記述の変更(64ビット版Excel対応)
'19/12/18(1.20)カレントパス取得をWshShellに変更､Option Private Module追加
'***************************************************************************************************
Option Explicit
Option Private Module
'===================================================================================================
Public Const g_cnsTitle As String = "フォルダを指定して下さい"
Private Const g_cnsTitle2 As String = "ファイルを指定して下さい"
Private Const g_cnsFileFilter As String = _
    "Excelワークブック (*.xlsx;*.xlsm;*.xls;*.xlsb),*.xlsx;*.xlsm;*.xls;*.xlsb,全てのファイル (*.*),*.*"
Private Const g_cnsFileFilter2 As String = _
    "Excelブック (*.xlsx),*.xlsx,Excelマクロ有効ブック (*.xlsm),*.xlsm" & _
    ",Excel97-2003ブック (*.xls),*.xls,Excelバイナリブック (*.xlsb),*.xlsb,全てのファイル (*.*),*.*"

'***************************************************************************************************
'   ■■■ ワークシートからの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名　：Button1_Click
'* 機能　　：｢フォルダの参照｣ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年04月14日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub Button1_Click()
    '-----------------------------------------------------------------------------------------------
    Dim strPathname As String                                       ' フォルダ名
    ' ｢フォルダの参照｣ダイアログよりフォルダ名の取得(引数は呼び先記述を参照)
    ' ※2つ目以降の引数は省略が可能です。
    strPathname = modFolderPicker2.FolderDialog(g_cnsTitle, _
                                                True, _
                                                ThisWorkbook.Path, _
                                                "選択")
    '-----------------------------------------------------------------------------------------------
    ' 結果の表示(キャンセル時はブランクが返る)
    If strPathname <> "" Then MsgBox strPathname
End Sub

'***************************************************************************************************
'* 処理名　：Button2_Click
'* 機能　　：｢フォルダの参照(UserFormから起動)｣ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年04月14日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub Button2_Click()
    '-----------------------------------------------------------------------------------------------
    ' UserFormを表示
    UserForm1.Show
End Sub

'***************************************************************************************************
'* 処理名　：Button3_Click
'* 機能　　：｢ファイルを開く(旧)｣ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年04月14日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub Button3_Click()
    '-----------------------------------------------------------------------------------------------
    Dim strFilename As String                                       ' ファイル名
    Dim vntFilename As Variant                                      ' ファイル名(受け取り)
    ' カレントフォルダ変更(自ブックフォルダ)
    Call modFolderPicker2.ChangeCurrentPath(ThisWorkbook.Path)
    ' ファイルを開くダイアログ表示(旧)
    vntFilename = Application.GetOpenFilename(g_cnsFileFilter, , g_cnsTitle2)
    ' カレントフォルダ復旧
    Call modFolderPicker2.ResetCurrentPath
    ' キャンセルは終了
    If VarType(vntFilename) = vbBoolean Then Exit Sub
    strFilename = vntFilename
    '-----------------------------------------------------------------------------------------------
    ' 結果の表示
    MsgBox strFilename
End Sub

'***************************************************************************************************
'* 処理名　：Button4_Click
'* 機能　　：｢ファイルを開く(新)｣ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年04月14日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub Button4_Click()
    '-----------------------------------------------------------------------------------------------
    Dim strFilename As String                                       ' ファイル名
    Dim tblFilter(2, 1) As String                                   ' ファイルフィルタ
    ' ファイルフィルタの設定
    tblFilter(0, 0) = "Excelワークブック"
    tblFilter(0, 1) = "*.xlsx;*.xlsm;*.xls;*.xlsb"
    tblFilter(1, 0) = "Excelテンプレート"
    tblFilter(1, 1) = "*.xlt;*.xltx;*.xltm"
    tblFilter(2, 0) = "全てのファイル"
    tblFilter(2, 1) = "*.*"
    ' ｢ファイルを開く｣ダイアログよりファイル名の取得(引数は呼び先記述を参照)
    ' ※2つ目以降の引数は省略が可能です。
    strFilename = modFolderPicker2.OpenDialog(g_cnsTitle2, _
                                              tblFilter, _
                                              True, _
                                              ThisWorkbook.Path, _
                                              "選択")
    '-----------------------------------------------------------------------------------------------
    ' 結果の表示(キャンセル時はブランクが返る)
    If strFilename <> "" Then MsgBox strFilename
End Sub

'***************************************************************************************************
'* 処理名　：Button5_Click
'* 機能　　：｢名前を付けて保存(旧)｣ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年04月14日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub Button5_Click()
    '-----------------------------------------------------------------------------------------------
    Const cnsFilename As String = "SAMPLE.xlsx"
    Dim strFilename As String                                       ' ファイル名
    Dim vntFilename As Variant                                      ' ファイル名(受け取り)
    ' カレントフォルダ変更(自ブックフォルダ)
    Call modFolderPicker2.ChangeCurrentPath(ThisWorkbook.Path)
    ' 名前を付けて保存ダイアログ表示(旧)
    vntFilename = Application.GetSaveAsFilename(cnsFilename, g_cnsFileFilter2, , g_cnsTitle2)
    ' カレントフォルダ復旧
    Call modFolderPicker2.ResetCurrentPath
    ' キャンセルは終了
    If VarType(vntFilename) = vbBoolean Then Exit Sub
    strFilename = vntFilename
    '-----------------------------------------------------------------------------------------------
    ' 結果の表示
    MsgBox strFilename
End Sub

'***************************************************************************************************
'* 処理名　：Button6_Click
'* 機能　　：｢名前を付けて保存(新)｣ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年04月14日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Sub Button6_Click()
    '-----------------------------------------------------------------------------------------------
    Const cnsFilename As String = "SAMPLE.xlsx"
    Dim strFilename As String                                       ' ファイル名
    ' ｢名前を付けて保存｣ダイアログよりファイル名の取得(引数は呼び先記述を参照)
    ' ※2つ目以降の引数は省略が可能です。
    strFilename = modFolderPicker2.SaveDialog(g_cnsTitle2, _
                                              cnsFilename, _
                                              True, _
                                              ThisWorkbook.Path, _
                                              "登録")
    '-----------------------------------------------------------------------------------------------
    ' 結果の表示(キャンセル時はブランクが返る)
    If strFilename <> "" Then MsgBox strFilename
End Sub

'***************************************************************************************************
'* 処理名　：Button7_Click
'* 機能　　：｢カレントフォルダ表示｣ボタンクリック
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月18日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Sub Button7_Click()
    '-----------------------------------------------------------------------------------------------
    ' カレントフォルダを取得して表示
    MsgBox modFolderPicker2.GetCurrentPath
End Sub

'----------------------------------------<< End of Source >>----------------------------------------

本ページの説明である「フォルダの参照」については「Button1_Click」だけ見ていただければ良いのですが、その他従来からある「ファイルを開く」「名前を付けて保存」についても従来方式と「Application.FileDialog」での方法を比較できるようにしてあります。
各プロシージャの概要は以下の通りです。

プロシージャ	説明
Button1_Click	「フォルダの参照」ボタンのクリック処理です。デフォルトではカレントフォルダは移動しないようになっており、処理で他フォルダを選択しても元に戻ります。起動時の初期フォルダは本ブックのフォルダになります。繰り返し呼び出すケースで、前回選択したフォルダを次回の初期フォルダにしたい場合は「modFolderPicker2.FolderDialog」を呼び出す際の引数に第5引数を「True」で追加して下さい。
Button2_Click	「フォルダの参照(UserFormから起動)」ボタンのクリック処理です。内容的には「Button1_Click」と同じですが、ユーザーフォーム上に「フォルダの参照」ボタンがあり、参照結果がユーザーフォーム上のテキストボックスに表示されるというものです。
Button3_Click	「ファイルを開く(旧)」ボタンのクリック処理です。従来からある「GetOpenFilename」メソッドでの「ファイルを開く」ダイアログの表示です。「Application.FileDialog」は「InitialFileName」プロパティでフォルダのフルパスを受け取ることで初期表示フォルダが指定できますが、「GetOpenFilename」メソッドの方はカレントフォルダを移動させて初期表示フォルダを指定するので、その処理と後で戻す処理を前後に挟んでいます。
Button4_Click	「ファイルを開く(新)」ボタンのクリック処理です。「Application.FileDialog」で「GetOpenFilename」メソッドと同様のことを行なっています。「ファイルを開く」ダイアログとしてはほとんど見かけは変わりません。
Button5_Click	「名前を付けて保存(旧)」ボタンのクリック処理です。従来からある「GetSaveAsFilename」メソッドでの「名前を付けて保存」ダイアログの表示です。最近のバージョンから「初期ファイル名」を指定してもダイアログに表示されないという事象があって、これは指定したファイル名の拡張子と先頭で指定したファイルフィルタが合っていないと表示されないということが報告されていました。このため、このサンプルでは「GetOpenFilename」メソッドとはファイルフィルタを区別して、単一拡張子のものを用意して対応しています。
Button6_Click	「名前を付けて保存(新)」ボタンのクリック処理です。「Application.FileDialog」で「GetSaveAsFilename」メソッドと同様のことを行なっています。仕様上で異なるのはファイルフィルタが指定できないことです。「初期ファイル名」を指定すればその拡張子が初期ファイルフィルタとして表示されます。「初期ファイル名」は「InitialFileName」プロパティで指定するのですが、これは同時に初期フォルダの指定にもなるので呼び出された「modFolderPicker2.SaveDialog」の方でフルパス編集を行なっています。
Button7_Click	「カレントフォルダ表示」ボタンのクリック処理です。これはカレントフォルダが移動したかどうかを確認するための表示のみの処理です。

次は実際の処理を行なう「modFolderPicker2.bas」です。
利用上ではソースコードの中身の理解は要らないように配慮しています。但し、呼び出す上での引数等の用意をどうするかなどは理解がないと利用できません。
「Button1_Click」のコードでは「FolderDialog」プロシージャの呼び出しで4つの引数をセットさせていますが、2番目以降は省略可能です。それぞれの引数の意味は以下のようになります。

項目	説明
①タイトル	表示ダイアログのタイトルです
②UNCパス変換	(OPTION)ネットワークドライブから指定された時に、該当のネットワークリソース名に変換する場合は、True、変換せずそのままにする場合はFalseを指定します。
③ルートフォルダ	(OPTION)選択状態にするフォルダがある場合はここで指定します。ブランクの場合は直前のカレントフォルダのままになります。
④ボタン表示名	(OPTION)デフォルトで「OK」となるボタンの表示名を指定することができます。
⑤ルートフォルダ固定スイッチ	(OPTION)繰り返し呼び出すような処理で、前回選択したフォルダを初期表示させたい場合は「True」をセットします。デフォルトは「False」なので、毎回設定した初期フォルダに戻ります。

「modFolderPicker2.bas」のソースコードは以下のようになっています。


'***************************************************************************************************
'   ファイル、フォルダ参照のダイアログ処理(Application.FileDialog)  modFolderPicker2(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'   [参照設定]
'   ・Microsoft Scripting Runtime
'   ・Windows Script Host Object Model
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'14/04/14(1.00)新規作成
'19/10/28(1.10)Declare記述の変更(64ビット版Excel対応)
'19/12/18(1.20)カレントパス取得・復旧を追加､Option Private Module追加､他記述整理
'***************************************************************************************************
Option Explicit
Option Private Module
'===================================================================================================
Private Const MAX_PATH As Long = 260
Private Const g_cnsYen As String = "\"
Private Const g_cnsCol As String = ":"
#If VBA7 Then
' ■ローカルドライブからマウントされているネットワークリソース名を取得する
Private Declare PtrSafe Function WNetGetConnection Lib "MPR.dll" _
    Alias "WNetGetConnectionA" _
    (ByVal lpszLocalName As String, _
     ByVal lpszRemoteName As String, _
     cbRemoteName As Long) As Long
#Else
' ■ローカルドライブからマウントされているネットワークリソース名を取得する
Private Declare Function WNetGetConnection Lib "MPR.dll" _
    Alias "WNetGetConnectionA" _
    (ByVal lpszLocalName As String, _
     ByVal lpszRemoteName As String, _
     cbRemoteName As Long) As Long
#End If
'---------------------------------------------------------------------------------------------------
' 設定退避変数
Private g_strCurrPathSV As String                                   ' 処理前のカレントフォルダ
Private g_strPrevPathSV As String                                   ' 直前選択フォルダ

'***************************************************************************************************
'   ■■■ 公開プロシージャ ■■■
'***************************************************************************************************
'* 処理名　：FolderDialog
'* 機能　　：｢フォルダの参照｣ダイアログ表示
'---------------------------------------------------------------------------------------------------
'* 返り値　：フォルダ名(フルパスで右\なし、未選択時はブランク)(String)
'* 引数　　：Arg1 = ウィンドウタイトル(String)
'* 　　　　　Arg2 = ネットワークドライブ→ネットワークリソースの置換区分(Boolean,Option)
'* 　　　　　Arg3 = ルートフォルダ(String,Option)
'* 　　　　　Arg4 = ボタン表示名(String,Option)
'* 　　　　　Arg5 = ルートフォルダ固定スイッチ(Boolean,Option)
'* 　　　　　       (True=固定する, False=元のカレントフォルダに戻す)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年04月14日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：「フォルダの参照」ダイアログを表示させ、選択したフォルダ名を返す
'* 注意事項：
'***************************************************************************************************
Public Function FolderDialog(ByVal strTitle As String, _
                             Optional ByVal blnNetGetConnection As Boolean = False, _
                             Optional ByVal strRootPath As String = "", _
                             Optional ByVal strButtonName As String = "OK", _
                             Optional ByVal swFixRootPath As Boolean = False) As String
    '-----------------------------------------------------------------------------------------------
    FolderDialog = ""
    ' ファイルダイアログの表示(FolderPicker)
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = strTitle
        ' ボタン名の設定
        If Len(strButtonName) > 0 Then
            .ButtonName = strButtonName
        End If
        .InitialFileName = FP_EditInitFileNm(swFixRootPath, strRootPath)
        .InitialView = msoFileDialogViewDetails
        .AllowMultiSelect = False
        ' ダイアログの表示
        If .Show Then
            FolderDialog = FP_GetUcnPath(.SelectedItems(1), blnNetGetConnection, swFixRootPath)
        End If
    End With
    ' ルートフォルダ固定スイッチがFalseならカレントフォルダ復旧
    If Not swFixRootPath Then Call ResetCurrentPath
End Function

'***************************************************************************************************
'* 処理名　：OpenDialog
'* 機能　　：｢ファイルを開く｣ダイアログ表示
'---------------------------------------------------------------------------------------------------
'* 返り値　：ファイル名(フルパス、未選択時はブランク)(String)
'* 引数　　：Arg1 = ウィンドウタイトル(String)
'* 　　　　　Arg2 = ファイルフィルタ(2次配列String,Option)
'* 　　　　　Arg3 = ネットワークドライブ→ネットワークリソースの置換区分(Boolean,Option)
'* 　　　　　Arg4 = ルートフォルダ(String,Option)
'* 　　　　　Arg5 = ボタン表示名(String,Option)
'* 　　　　　Arg6 = ルートフォルダ固定スイッチ(Boolean,Option)
'* 　　　　　       (True=固定する, False=元のカレントフォルダに戻す)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年04月14日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：「ファイルを開く」ダイアログを表示させ、選択したファイル名を返す
'* 注意事項：単一ファイル専用
'***************************************************************************************************
Public Function OpenDialog(ByVal strTitle As String, _
                           Optional ByRef tblFilter As Variant, _
                           Optional ByVal blnNetGetConnection As Boolean = False, _
                           Optional ByVal strRootPath As String = "", _
                           Optional ByVal strButtonName As String = "開く", _
                           Optional ByVal swFixRootPath As Boolean = False) As String
    '-----------------------------------------------------------------------------------------------
    Dim intIx As Integer                                            ' テーブルINDEX
    OpenDialog = ""
    ' ファイルダイアログの表示(FileDialogOpen)
    With Application.FileDialog(msoFileDialogOpen)
        .Title = strTitle
        ' ボタン名の設定
        If Len(strButtonName) > 0 Then
            .ButtonName = strButtonName
        End If
        ' ファイルフィルタの設定
        If IsArray(tblFilter) Then
            With .Filters
                .Clear
                intIx = 0
                Do While intIx <= UBound(tblFilter)
                    .Add tblFilter(intIx, 0), tblFilter(intIx, 1), intIx + 1
                    intIx = intIx + 1
                Loop
            End With
        End If
        .InitialFileName = FP_EditInitFileNm(swFixRootPath, strRootPath)
        .InitialView = msoFileDialogViewDetails
        .AllowMultiSelect = False
        ' ダイアログの表示
        If .Show Then
            OpenDialog = FP_GetUcnPath(.SelectedItems(1), blnNetGetConnection, swFixRootPath)
        End If
    End With
    ' ルートフォルダ固定スイッチがFalseならカレントフォルダ復旧
    If Not swFixRootPath Then Call ResetCurrentPath
End Function

'***************************************************************************************************
'* 処理名　：SaveDialog
'* 機能　　：｢名前を付けて保存｣ダイアログ表示
'---------------------------------------------------------------------------------------------------
'* 返り値　：ファイル名(フルパス、未選択時はブランク)(String)
'* 引数　　：Arg1 = ウィンドウタイトル(String)
'* 　　　　　Arg2 = デフォルトファイル名(String,Option)
'* 　　　　　Arg3 = ネットワークドライブ→ネットワークリソースの置換区分(Boolean,Option)
'* 　　　　　Arg4 = ルートフォルダ(String,Option)
'* 　　　　　Arg5 = ボタン表示名(String,Option)
'* 　　　　　Arg6 = ルートフォルダ固定スイッチ(Boolean,Option)
'* 　　　　　       (True=固定する, False=元のカレントフォルダに戻す)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年04月14日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：「名前を付けて保存」ダイアログを表示させ、選択したファイル名を返す
'* 注意事項：
'***************************************************************************************************
Public Function SaveDialog(ByVal strTitle As String, _
                           Optional ByVal strInitFilename As String = "", _
                           Optional ByVal blnNetGetConnection As Boolean = False, _
                           Optional ByVal strRootPath As String = "", _
                           Optional ByVal strButtonName As String = "保存", _
                           Optional ByVal swFixRootPath As Boolean = False) As String
    '-----------------------------------------------------------------------------------------------
    SaveDialog = ""
    ' ファイルダイアログの表示(FileDialogSaveAs)
    ' この方法ではファイルフィルタの指定ができません
    With Application.FileDialog(msoFileDialogSaveAs)
        .Title = strTitle
        ' デフォルトファイル名
        .InitialFileName = FP_EditInitFileNm(swFixRootPath, strRootPath, strInitFilename)
        ' ボタン名の設定
        If Len(strButtonName) > 0 Then
            .ButtonName = strButtonName
        End If
        .InitialView = msoFileDialogViewDetails
        .AllowMultiSelect = False
        ' ダイアログの表示
        If .Show Then
            SaveDialog = FP_GetUcnPath(.SelectedItems(1), blnNetGetConnection, swFixRootPath)
        End If
    End With
    ' ルートフォルダ固定スイッチがFalseならカレントフォルダ復旧
    If Not swFixRootPath Then Call ResetCurrentPath
End Function

'***************************************************************************************************
'* 処理名　：GetResourceNameFromLocalDrive
'* 機能　　：ネットワークドライブシンボルからネットワークリソースを取得
'---------------------------------------------------------------------------------------------------
'* 返り値　：パス名(String)
'* 引数　　：Arg1 = パス名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2014年04月14日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Function GetResourceNameFromLocalDrive(strDrv As String) As String
    '-----------------------------------------------------------------------------------------------
    Dim strBuf As String                                            ' 文字列バッファ
    Dim strDriveName As String                                      ' ドライブシンボル
    Dim lngLen As Long                                              ' 文字列長
    strDriveName = Left$(strDrv, 1) & g_cnsCol
    On Error GoTo GetResourceNameFromLocalDrive_ERROR
    strBuf = String$(MAX_PATH + 1, vbNullChar)
    WNetGetConnection strDriveName, strBuf, MAX_PATH
    '取得したパス名から必要な文字列だけを抽出
    lngLen = InStr(1, strBuf, vbNullChar)
    If lngLen > 1 Then
        GetResourceNameFromLocalDrive = Left$(strBuf, lngLen - 1)
    Else
        GetResourceNameFromLocalDrive = strDriveName
    End If
    GoTo GetResourceNameFromLocalDrive_EXIT
'===================================================================================================
' エラー処理
GetResourceNameFromLocalDrive_ERROR:
    GetResourceNameFromLocalDrive = strDriveName
'===================================================================================================
' 終了
GetResourceNameFromLocalDrive_EXIT:
    On Error GoTo 0
End Function

'***************************************************************************************************
'* 処理名　：ChangeCurrentPath
'* 機能　　：カレントフォルダ変更
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：Arg1 = フォルダ名(String)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月18日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub ChangeCurrentPath(strPathname As String)
    '-----------------------------------------------------------------------------------------------
    Dim objShell As WshShell                                        ' WshShell
    ' フォルダの指定があるか
    If strPathname <> "" Then
        ' 直前のカレントフォルダ退避
        Set objShell = New WshShell
        ' カレントフォルダが指定フォルダと異なるか
        If objShell.CurrentDirectory <> strPathname Then
            g_strCurrPathSV = objShell.CurrentDirectory
            ' カレントフォルダを変更
            objShell.CurrentDirectory = strPathname
        End If
        Set objShell = Nothing
    End If
End Sub

'***************************************************************************************************
'* 処理名　：ResetCurrentPath
'* 機能　　：カレントフォルダ復旧
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月18日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Sub ResetCurrentPath()
    '-----------------------------------------------------------------------------------------------
    Dim objShell As WshShell                                        ' WshShell
    ' 直前のカレントフォルダが退避されているか
    If g_strCurrPathSV <> "" Then
        Set objShell = New WshShell
        ' カレントフォルダを変更
        objShell.CurrentDirectory = g_strCurrPathSV
        Set objShell = Nothing
    End If
End Sub

'***************************************************************************************************
'* 処理名　：GetCurrentPath
'* 機能　　：カレントフォルダ取得
'---------------------------------------------------------------------------------------------------
'* 返り値　：パス名(String)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月18日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Public Function GetCurrentPath() As String
    '-----------------------------------------------------------------------------------------------
    Dim objShell As WshShell                                        ' WshShell
    Set objShell = New WshShell
    ' カレントフォルダを取得
    GetCurrentPath = objShell.CurrentDirectory
    Set objShell = Nothing
End Function

'***************************************************************************************************
'   ■■■ サブプロシージャ(Private) ■■■
'***************************************************************************************************
'* 処理名　：FP_EditInitFileNm
'* 機能　　：デフォルトファイル名の編集
'---------------------------------------------------------------------------------------------------
'* 返り値　：デフォルトファイル名(String)
'* 引数　　：Arg1 = ルートフォルダ固定スイッチ(Boolean)
'* 　　　　　Arg2 = ルートフォルダ(String)
'* 　　　　　Arg3 = デフォルトファイル名(String,Option)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月18日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_EditInitFileNm(ByVal swFixRootPath As Boolean, _
                                   ByVal strRootPath As String, _
                                   Optional ByVal strInitFilename As String = "") As String
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim strInitFilename2 As String                                  ' デフォルトファイル名(フルパス)
    ' カレントフォルダ退避が初回の時は退避する
    If g_strCurrPathSV = "" Then
        ' カレントフォルダ退避
        Call GP_SaveCurrentPath
    End If
    ' ルートフォルダ指定無しの時はカレントフォルダを適用
    If strRootPath = "" Then strRootPath = g_strCurrPathSV
    '-----------------------------------------------------------------------------------------------
    ' ルートフォルダ固定の場合は前回のフォルダをルートフォルダとする
    If swFixRootPath And g_strPrevPathSV <> "" Then
        strRootPath = g_strPrevPathSV
    End If
    ' ファイル名があるか
    If strInitFilename <> "" Then
        Set objFso = New FileSystemObject
        strInitFilename2 = objFso.BuildPath(strRootPath, strInitFilename)
        Set objFso = Nothing
    Else
        strInitFilename2 = FP_ApendYenSign(strRootPath)
    End If
    ' ルートフォルダ固定でなければ現フォルダを退避
    If Not swFixRootPath Then g_strPrevPathSV = strRootPath
    FP_EditInitFileNm = strInitFilename2
End Function

'***************************************************************************************************
'* 処理名　：GP_SaveCurrentPath
'* 機能　　：カレントフォルダ退避
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月18日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Sub GP_SaveCurrentPath()
    '-----------------------------------------------------------------------------------------------
    Dim objShell As WshShell                                        ' WshShell
    Set objShell = New WshShell
    g_strCurrPathSV = objShell.CurrentDirectory
    Set objShell = Nothing
End Sub

'***************************************************************************************************
'* 処理名　：FP_GetUcnPath
'* 機能　　：ローカルドライブからネットワークリソース名を取得
'---------------------------------------------------------------------------------------------------
'* 返り値　：UCNパス名(String)
'* 引数　　：Arg1 = 選択フォルダ名(String)
'* 　　　　　Arg2 = ネットワークドライブ→ネットワークリソースの置換区分(Boolean)
'* 　　　　　Arg3 = ルートフォルダ固定スイッチ(Boolean)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月18日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：ローカルドライブ(ネットワークドライブ)からネットワークリソース名を取得する
'* 注意事項：
'***************************************************************************************************
Private Function FP_GetUcnPath(ByVal strPathname As String, _
                               ByVal blnNetGetConnection As Boolean, _
                               ByVal swFixRootPath As Boolean) As String
    '-----------------------------------------------------------------------------------------------
    Dim objFso As FileSystemObject                                  ' FileSystemObject
    Dim strPathname2 As String                                      ' フォルダ名(Work)
    ' ルートフォルダ固定の場合は選択フォルダ名を退避
    If swFixRootPath Then
        strPathname2 = strPathname
        Set objFso = New FileSystemObject
        ' フルパス名の場合はフォルダ部分のみに変更
        If Not objFso.FolderExists(strPathname2) Then
            strPathname2 = objFso.GetParentFolderName(strPathname2)
        End If
        Set objFso = Nothing
        g_strPrevPathSV = strPathname2
    End If
    ' ローカルドライブ(ネットワークドライブ)から
    ' マウントされているネットワークリソース名を取得する
    If (blnNetGetConnection And (Mid$(strPathname, 2, 1) = g_cnsCol)) Then
        strPathname2 = GetResourceNameFromLocalDrive(strPathname)
        If Left(strPathname2, 2) = g_cnsYen & g_cnsYen Then
            strPathname = strPathname2 & Mid(strPathname, 3)
        End If
    End If
    FP_GetUcnPath = strPathname
End Function

'***************************************************************************************************
'* 処理名　：FP_ApendYenSign
'* 機能　　：右\付加
'---------------------------------------------------------------------------------------------------
'* 返り値　：編集後文字列(String)
'* 引数　　：Arg1 = 編集前文字列(String)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2019年12月18日
'* 作成者　：井上　治
'* 更新日　：2019年12月18日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：
'***************************************************************************************************
Private Function FP_ApendYenSign(ByVal strInText As String) As String
    '-----------------------------------------------------------------------------------------------
    If Right(strInText, 1) = g_cnsYen Then
        FP_ApendYenSign = strInText
    Else
        FP_ApendYenSign = strInText & g_cnsYen
    End If
End Function

'----------------------------------------<< End of Source >>----------------------------------------

←MsoFolderPicker2.zip
(49KB)

従来バージョン(WindowsAPI版)が必要な方は以下からどうぞ

詳細な説明は削除してしまいましたが、ダウンロードはできるようにしてあります。

←modSHBrowseForFolder.zip
(46KB)