きなこSHOW

VBAと日々の戯言

【VBA】ファイル選択ダイアログ Excel & Accessコードサンプル

スポンサーリンク

ファイル選択ダイアログのコードは、web上で多くのサンプルが公開されているので、簡単に入手できると思います。
もちろんそのまま使ってもいいんですが、今回のサンプルはファイル拡張子からフィルタ文字列を自動で組み立てるモジュールとセットにしました。
Excelから呼び出し、Accessから呼び出しの2種類に対応した、コピーしてそのまま使えるコードを紹介します。

2種類のサンプルを掲載します

ファイル選択はOfficeに含まれるFileDialogを呼び出すタイプが主流かと思いますが、APIの「GetOpenFileName」を呼び出すっていうクラシックなやつも未だ現役で稼働しているので、2種類を掲載します。
ただしごめんなさい。AccessのWizhookを使ったやつは対応してません。

前置き長過ぎすみません。コピーしてそのまま使えるコード行きます。

OfficeオブジェクトのFileDialogを使用したファイル選択ダイアログ

準備として、参照設定「Microsoft Office x.x Object Library」にチェックを付けます。
参照設定
「x.x」の数字はインストールされているOfficeのバージョンによって異なります。

OfficeのFileDialogを使用したファイル選択ダイアログ vbaソース

上記の参照設定をした上で、標準モジュールを新規作成して、以下のコードを貼り付けてください。

ひとつ気を付けていただきたい点は、初期フォルダの設定の部分で「InitialFileName」が省略された場合の値がExcelとAccessで異なるので、実装するときに編集してください。

  • Excelで使用する場合は「vInitialFileName = ThisWorkbook.FullName '(Excelの場合)」の行を残してAccessの場合の行を削除します。
  • Accessで使用する場合は「vInitialFileName = CurrentProject.Path '(Accessの場合)」の行を残してExcelの場合の行を削除します。
Option Explicit

Private Const C_DELIMITER   As String = ","

'***************************************************************************
'名称 :GetFileName
'機能 :ファイル選択ダイアログ
'引数 :vInitialFileName       (I )    String  初期ファイル名
'   :vTitle                 (I )    String  ダイアログ標題
'   :vFilter                (I )    Variant フィルタ拡張子
'   :vbAllowMultiSelect     (I )    Boolean True = 複数選択
'戻り値:ファイル名(MultiSelectの場合カンマ区切り)
'作成 :2018/07/01 kinacco
'更新 :
'***************************************************************************
Public Function GetFileName(ByVal vInitialFileName As String _
                          , ByVal vTitle As String, ByVal vFilter As Variant _
                 , Optional ByRef vbAllowMultiSelect As Boolean = False) As String
Dim lvSelectedFile  As Variant
Dim lvArray         As Variant
Dim lsFileBaseName  As String
Dim lsExtension     As String
Dim lsReturn        As String
Dim llFilterIndex   As Long
Dim i As Long, j As Long

    '--- 初期値セット ---
    lsReturn = ""
    lsExtension = ""
    
    '--- 初期フォルダの設定 ---
    If vInitialFileName = "" Then
        vInitialFileName = CurrentProject.Path   '(Accessの場合)
        vInitialFileName = ThisWorkbook.FullName '(Excelの場合)
    Else
        '--- 拡張子を取り出す ---
        If InStr(1, vInitialFileName, ".", vbTextCompare) > 0 Then
            lsExtension = Mid(vInitialFileName, InStrRev(vInitialFileName, "."))
        End If
    End If
    
    '--- フィルタ文字列を取得 ---
    lvArray = Split(msGetFileFilter(vFilter), C_DELIMITER)
    
    With Application.FileDialog(msoFileDialogFilePicker)
        
        If vTitle = "" Then
            .Title = "ファイルを選択してください"
        Else
            .Title = vTitle
        End If
        If vbAllowMultiSelect Then
            .Title = .Title & "(複数選択)"
        End If
        .ButtonName = "選択"
        .AllowMultiSelect = vbAllowMultiSelect
        
        llFilterIndex = 0

        '--- フィルタ文字列を設定する ---
        .Filters.Clear
        For i = LBound(lvArray) To UBound(lvArray) - 1 Step 2
            .Filters.Add lvArray(i), Trim(lvArray(i + 1))
            If lsExtension <> "" Then
                If InStr(1, Trim(lvArray(i + 1)), lsExtension, vbTextCompare) > 0 Then
                    llFilterIndex = .Filters.Count
                End If
            End If
        Next i
        
        '--- FilterIndexの設定 ---
        If llFilterIndex > 0 Then
            .FilterIndex = llFilterIndex
        Else
            .FilterIndex = 1
        End If
        '--- ファイルのベース名を取得 ---
        lsFileBaseName = Mid(vInitialFileName, InStrRev(vInitialFileName, "\") + 1)
        lsFileBaseName = Left(lsFileBaseName, InStr(lsFileBaseName, ".") - 1)
        If lsFileBaseName = "*" Then
            '--- ベース名が"*"の場合フィルタが無効になるのを回避 ---
            .InitialFileName = Left(vInitialFileName, InStrRev(vInitialFileName, "\"))
        Else
            .InitialFileName = vInitialFileName
        End If
        .InitialView = msoFileDialogViewDetails
        If CBool(.Show) Then
            If .SelectedItems.Count >= 1 Then
            '--- 戻り値用の変数に出力 ---
            For Each lvSelectedFile In .SelectedItems
                If lsReturn <> "" Then lsReturn = lsReturn & C_DELIMITER
                lsReturn = lsReturn & CStr(lvSelectedFile)
            Next lvSelectedFile
            End If
        Else
            '--- キャンセルボタンがクリックされた場合 ---
            lsReturn = ""
        End If
    End With
    
    GetFileName = lsReturn
    
End Function

'***************************************************************************
'名称 :msGetFileFilter
'機能 :フィルタ文字列作成
'引数 :vsFilter               (I )    String
'戻り値:フィルタ文字列(カンマ区切り)
'作成 :2018/07/01 kinacco
'更新 :
'***************************************************************************
Private Function msGetFileFilter(ByVal vArrFilter As Variant) As String
On Error GoTo ERR_SEC
Dim lbHitxlsx       As Boolean
Dim lbHitxls        As Boolean
Dim lsMsg           As String
Dim lsWork          As String
Dim lsFilter        As String
Dim lsReturn        As String
Dim lvArrFilter     As Variant
Dim i As Long, j As Long

    '--- 初期値セット ---
    lsMsg = ""
    lsReturn = "すべてのファイル,*.*"
    lbHitxlsx = False
    lbHitxls = False
    
    '--- 省略時はALL設定 ---
    If vArrFilter = "" Then GoTo EXIT_SEC
    
    '--- 配列に分割 ---
    lvArrFilter = Split(vArrFilter, ",")
    
    '--- 拡張子に対応するタイトルを設定する ---
    lsFilter = ""
    For i = LBound(lvArrFilter) To UBound(lvArrFilter)
        lsWork = LCase(Trim(lvArrFilter(i)))
        
        Select Case True
            ' Excel
            Case Right(lsWork, 5) = ".xlsx", Right(lsWork, 4) = ".xls"
                If Not lbHitxlsx And Not lbHitxls Then
                    For j = i To UBound(lvArrFilter)
                        If Right(lvArrFilter(j), 5) = ".xlsx" Then
                            lbHitxlsx = True
                        End If
                        If Right(lvArrFilter(j), 4) = ".xls" Then
                            lbHitxls = True
                        End If
                        If lbHitxlsx And lbHitxls Then Exit For
                    Next j
                    If lbHitxlsx And lbHitxls Then
                        If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                        lsFilter = lsFilter & "Excelファイル (xlsx/xls)" & C_DELIMITER & "*.xlsx;*.xls"
                    ElseIf lbHitxlsx Then
                        If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                        lsFilter = lsFilter & "Excelファイル (xlsx)" & C_DELIMITER & "*.xlsx"
                    ElseIf lbHitxls Then
                        If Len(lsFilter) > 0 Then lsFilter = lsFilter & ","
                        lsFilter = lsFilter & "Excel97-2003ファイル (xls)" & C_DELIMITER & "*.xls"
                    End If
                End If
            ' Excelマクロ有効Book
            Case Right(lsWork, 5) = ".xlsm"
                If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                lsFilter = lsFilter & "Excelマクロ有効Book, *.xlsm"
            ' CSV
            Case Right(lsWork, 4) = ".csv"
                If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                lsFilter = lsFilter & "CSVファイル, *.csv"
            ' txt
            Case Right(lsWork, 4) = ".txt"
                If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                lsFilter = lsFilter & "テキストァイル, *.txt"
            ' ZIP
            Case Right(lsWork, 4) = ".zip"
                If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                lsFilter = lsFilter & "ZIPファイル, *.zip"
            ' その他
            Case Else
                If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                lsFilter = lsFilter & Replace(lsWork, ".", "") & "ファイル" & C_DELIMITER & "*" & lsWork
        End Select
    Next i
    
    If Len(lsFilter) > 0 Then
        lsReturn = lsFilter & C_DELIMITER & lsReturn
    End If
    
EXIT_SEC:
On Error Resume Next

    msGetFileFilter = lsReturn
    
    Exit Function

ERR_SEC:
    lsMsg = "予期せぬエラーが発生しました。" & vbCrLf & _
            "プロシージャ名:msGetFileFilter" & vbCrLf & _
            "エラー番号:" & Err.Number & vbCrLf & _
            "エラー内容:" & Err.Description
    Call gOutputLog(lsMsg)
    Resume EXIT_SEC
End Function

 

VBAからの呼び出し例

VBAで使用する場合は、文字列型の変数を戻り値に指定して次のように記述します。

Dim sFileName   As String
    sFileName = GetFileName("C:\hoge\2019??.txt","",".txt,.csv",False)

ダイアログがキャンセルで閉じられた場合、戻り値には空文字("")がセットされます。

引数にはそれぞれ次の内容をセットします。

第1引数:ダイアログを開いたときに表示するフォルダと、ファイル名のパターンを指定します。
パターンは「?」が任意の1文字を、「*」が任意の複数の文字を表します。
第2引数:ダイアログボックスのタイトルに表示する文字列を指定します。
省略した場合は、「ファイルを選択してください」というタイトルになります。
第3引数:フィルタに表示したい拡張子を一定の法則で指定します。
指定方法は、「.拡張子1, .拡張子2 ...」のように、フィルタに表示させたい拡張子をカンマ区切りで記入します。

第3引数に指定した文字列はプロシージャ「msGetFileFilter」でフィルタ文字列を組立てて返します。

フィルタを展開してるとこ
余計なお世話かもしれませんが、拡張子の指定に「.*」が含まれない場合、最後に追加しています。イヤだったら外してください。

 

マクロからの呼び出し例

Accessのマクロから呼び出すこともできます。
こんな風に。

Accessマクロからの呼び出し例

ローカル変数の式にこのプロシージャを記述することで、マクロでもファイル選択ダイアログを使用することが可能です。

API を利用したファイル選択ダイアログ

APIの方はコモンダイアログ32をコードの中で参照しているので参照設定は不要です。
このAPIいつまで使えるんだろうね。時々心配になります。

API版ファイル選択ダイアログ vbaソース

標準モジュールを新規作成して、以下のコードを貼り付けてください。

Option Explicit

#If Win64 Then
    '=======================
    ' ファイルを開くダイアログボックス
    '=======================
    Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _
        Alias "GetOpenFileNameA" (lpofn As OPENFILENAME) As LongPtr
    
    '=============================
    ' [ファイル名を付けて保存] ダイアログボックス
    '=============================
    Public Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" _
        Alias "GetSaveFileNameA" (lpofn As OPENFILENAME) As LongPtr
    
    '=======================
    ' OPENFILENAME構造体
    '=======================
    Public Type OPENFILENAME
        lStructSize As Long           '構造体のサイズ
        hwndOwner As LongPtr             'ウインドウのハンドル
        hInstance As LongPtr             'インスタンスハンドル
        lpstrFilter As String         'フィルタ
        lpstrCustomFilter As String   'カスタムフィルタ
        nMaxCustFilter As Long        'カスタムフィルタのサイズ
        nFilterIndex As Long          'フィルタのインデックス
        lpstrFile As String           'ファイル名のバッファ
        nMaxFile As Long              'ファイル名のバッファのサイズ
        lpstrFileTitle As String      'フルパス用のバッファ
        nMaxFileTitle As Long         'フルパス用のバッファのサイズ
        lpstrInitialDir As String     'ディレクトリを指定
        lpstrTitle As String          'ダイヤログボックスのタイトル
        Flags As Long                 '定数(OFN_××参照)
        nFileOffset As Integer        'フルパスの中のファイル名までのオフセット
        nFileExtension As Integer     '拡張子までのオフセット
        lpstrDefExt As String         'デフォルトの拡張子
        lCustData As Long             'lpfnHookで渡すデータ
        lpfnHook As LongPtr              'フック関数のポインタ
        lpTemplateName As String      'テンプレート名
    End Type
#Else
    '=======================
    ' ファイルを開くダイアログボックス
    '=======================
    Public Declare Function GetOpenFileName Lib "comdlg32.dll" _
        Alias "GetOpenFileNameA" (lpofn As OPENFILENAME) As Long
    
    '=============================
    ' [ファイル名を付けて保存] ダイアログボックス
    '=============================
    Public Declare Function GetSaveFileName Lib "comdlg32.dll" _
        Alias "GetSaveFileNameA" (lpofn As OPENFILENAME) As Long
    
    '=======================
    ' OPENFILENAME構造体
    '=======================
    Public Type OPENFILENAME
        lStructSize As Long           '構造体のサイズ
        hwndOwner As Long             'ウインドウのハンドル
        hInstance As Long             'インスタンスハンドル
        lpstrFilter As String         'フィルタ
        lpstrCustomFilter As String   'カスタムフィルタ
        nMaxCustFilter As Long        'カスタムフィルタのサイズ
        nFilterIndex As Long          'フィルタのインデックス
        lpstrFile As String           'ファイル名のバッファ
        nMaxFile As Long              'ファイル名のバッファのサイズ
        lpstrFileTitle As String      'フルパス用のバッファ
        nMaxFileTitle As Long         'フルパス用のバッファのサイズ
        lpstrInitialDir As String     'ディレクトリを指定
        lpstrTitle As String          'ダイヤログボックスのタイトル
        Flags As Long                 '定数(OFN_××参照)
        nFileOffset As Integer        'フルパスの中のファイル名までのオフセット
        nFileExtension As Integer     '拡張子までのオフセット
        lpstrDefExt As String         'デフォルトの拡張子
        lCustData As Long             'lpfnHookで渡すデータ
        lpfnHook As Long              'フック関数のポインタ
        lpTemplateName As String      'テンプレート名
    End Type
#End If

Public Const OFN_ALLOWMULTISELECT = &H200   '複数ファイルを選択可能にする
Public Const OFN_CREATEPROMPT = &H2000      '指定のファイル名が存在しない時にメッセージボックスを表示
Public Const OFN_FILEMUSTEXIST = &H1000     '無効なファイル名は受け付けない
Public Const OFN_HIDEREADONLY = &H4         '読み取り専用のチェックボックスを非表示
Public Const OFN_NOCHANGEDIR = &H8          '他のサブディレクトリから選択不可
Public Const OFN_NOREADONLYRETURN = &H8000  '読み込み専用ファイルと書きこみ禁止ディレクトリの選択不可
Public Const OFN_NOVALIDATE = &H100         'ファイル名の有効性をチェックしない
Public Const OFN_OVERWRITEPROMPT = &H2      '既存のファイル名を指定した時にメッセージを出す
Public Const OFN_PATHMUSTEXIST = &H800      '無効なパスは受け付けない
Public Const OFN_READONLY = &H1             '読み取り専用のチェックボックスをチェック
Public Const OFN_SHOWHELP = &H10            'ヘルプボタンを表示
Public Const OFN_EXPLORER = &H80000         'エクスプローラー風表示
Public Const AllFile = "すべてのファイル"

Private Const C_DELIMITER   As String = ","

'=======================================
'■関数名       apiGetOpenFileName
'■用途         「ファイルを開く」ダイアログボックスを表示する
'■引数         vInitialDir :デフォルトのフォルダ位置
'               vFile    :デフォルトのファイル名
'               vTitle   :ダイアログタイトル
'               vFilter  :ファイルフィルタ
'               vbAllowMultiSelect  :True=複数ファイル選択可能
'■戻り値       ファイルを選択した場合 ファイル名(フルパス)
'               キャンセルを押した場合 vbNullString("")
'=======================================
Public Function apiGetOpenFileName(ByVal vInitialDir As String, ByVal vFile As String _
                                 , ByVal vTitle As String, ByVal vFilter As Variant _
                        , Optional ByRef vbAllowMultiSelect As Boolean = False) As Variant
Const BUFF_SIZE_FULL = 512
Const BUFF_SIZE_FILE = 256
Dim OFN             As OPENFILENAME     'OPENFILENAME構造体
Dim llRet           As LongPtr
Dim lsDir           As String
Dim lsFileFilter    As String
Dim lvResult        As Variant
Dim lvReturn        As Variant
Dim i As Long

    lsDir = ""
    lvReturn = ""

    '--- FileFilter作成 ---
    lsFileFilter = Replace(msGetFileFilter(vFilter), C_DELIMITER, Chr(0), , , vbTextCompare)

    '--- 構造体の設定 ---
    With OFN
        If vbAllowMultiSelect Then
            .Flags = OFN_EXPLORER Or _
                    OFN_PATHMUSTEXIST Or _
                    OFN_FILEMUSTEXIST Or _
                    OFN_HIDEREADONLY Or _
                    OFN_ALLOWMULTISELECT
        Else
            .Flags = OFN_EXPLORER Or _
                    OFN_PATHMUSTEXIST Or _
                    OFN_FILEMUSTEXIST Or _
                    OFN_HIDEREADONLY
        End If
        .hwndOwner = Application.hWndAccessApp  'ウインドウハンドルを設定
        .hInstance = 0                          'インスタンスハンドルを設定 (App.hInstance)
        .lpstrFilter = lsFileFilter             'フィルタを設定
        .nFilterIndex = 1                       'フィルタインデックスを設定
        
        If Len(vFile) <= 0 Then                 'ファイル名のバッファを確保
            .lpstrFile = String(BUFF_SIZE_FILE, Chr(0))
        Else
            .lpstrFile = vFile & String(BUFF_SIZE_FILE - Len(vFile), Chr(0))
        End If
                
        #If Win64 Then
            .nMaxFile = LenB(.lpstrFile) - 1    'ファイル名のバッファのサイズを設定
            .lStructSize = LenB(OFN)            '構造体のサイズを設定
        #Else
            .nMaxFile = Len(.lpstrFile) - 1     'ファイル名のバッファのサイズを設定
            .lStructSize = Len(OFN)             '構造体のサイズを設定
        #End If
        
        .lpstrFileTitle = String(BUFF_SIZE_FULL, Chr(0))    'フルパス用のバッファを確保
        .nMaxFileTitle = Len(.lpstrFileTitle)               'フルパス用のバッファのサイズを設定
        
        If Len(vTitle) <= 0 Then vTitle = "ファイルを選択してください"
        .lpstrInitialDir = vInitialDir                 'デフォルトのディレクトリを指定
        .lpstrTitle = vTitle                    'タイトルを設定
    End With

    '--- 砂時計ポインタになっていたら元に戻す ---
    DoCmd.Hourglass False

    llRet = GetOpenFileName(OFN)    '「ファイルを開く」ダイアログボックスを表示する

    If llRet = 0 Then               'キャンセル時、
        apiGetOpenFileName = vbNullString   ' ""を返す
    Else                            'OKクリック時
'        apiGetOpenFileName = Left$(OFN.lpstrFile, InStr(OFN.lpstrFile, Chr(0)) - 1)
'        複数選択の場合、ドライブ名+ディレクトリ名 |ファイル名|ファイル名|・・・||
        lvResult = Split(OFN.lpstrFile, Chr(0))
        lvReturn = ""
        '--- ダイアログ戻り値から空文字を除去する ---
        For i = 0 To UBound(lvResult)
            If lvResult(i) = vbNullString Then Exit For
            If Len(lvReturn) > 0 Then lvReturn = lvReturn & C_DELIMITER
            lvReturn = lvReturn & lvResult(i)
        Next i
        lvResult = Split(lvReturn, C_DELIMITER)
        '--- ファイルが複数指定された場合、フルパスで返す ---
        If UBound(lvResult) >= 1 Then
            lvReturn = ""
            lsDir = lvResult(0)
            If Right(lsDir, 1) <> "" Then lsDir = lsDir & ""
            For i = 1 To UBound(lvResult)
                If Len(lvReturn) > 0 Then lvReturn = lvReturn & C_DELIMITER
                lvReturn = lvReturn & lsDir & lvResult(i)
            Next
        End If
        apiGetOpenFileName = lvReturn
    End If

End Function

'***************************************************************************
'名称 :msGetFileFilter
'機能 :フィルタ文字列作成
'引数 :vsFilter               (I )    String
'戻り値:フィルタ文字列(カンマ区切り)
'作成 :2018/07/01 kinacco
'更新 :
'***************************************************************************
Private Function msGetFileFilter(ByVal vArrFilter As Variant) As String
On Error GoTo ERR_SEC
Dim lbHitxlsx       As Boolean
Dim lbHitxls        As Boolean
Dim lsMsg           As String
Dim lsWork          As String
Dim lsFilter        As String
Dim lsReturn        As String
Dim lvArrFilter     As Variant
Dim i As Long, j As Long

    '--- 初期値セット ---
    lsMsg = ""
    lsReturn = "すべてのファイル,*.*"
    lbHitxlsx = False
    lbHitxls = False
    
    '--- 省略時はALL設定 ---
    If vArrFilter = "" Then GoTo EXIT_SEC
    
    '--- 配列に分割 ---
    lvArrFilter = Split(vArrFilter, ",")
    
    '--- 拡張子に対応するタイトルを設定する ---
    lsFilter = ""
    For i = LBound(lvArrFilter) To UBound(lvArrFilter)
        lsWork = LCase(Trim(lvArrFilter(i)))
        
        Select Case True
            ' Excel
            Case Right(lsWork, 5) = ".xlsx", Right(lsWork, 4) = ".xls"
                If Not lbHitxlsx And Not lbHitxls Then
                    For j = i To UBound(lvArrFilter)
                        If Right(lvArrFilter(j), 5) = ".xlsx" Then
                            lbHitxlsx = True
                        End If
                        If Right(lvArrFilter(j), 4) = ".xls" Then
                            lbHitxls = True
                        End If
                        If lbHitxlsx And lbHitxls Then Exit For
                    Next j
                    If lbHitxlsx And lbHitxls Then
                        If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                        lsFilter = lsFilter & "Excelファイル (xlsx/xls)" & C_DELIMITER & "*.xlsx;*.xls"
                    ElseIf lbHitxlsx Then
                        If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                        lsFilter = lsFilter & "Excelファイル (xlsx)" & C_DELIMITER & "*.xlsx"
                    ElseIf lbHitxls Then
                        If Len(lsFilter) > 0 Then lsFilter = lsFilter & ","
                        lsFilter = lsFilter & "Excel97-2003ファイル (xls)" & C_DELIMITER & "*.xls"
                    End If
                End If
            ' Excelマクロ有効Book
            Case Right(lsWork, 5) = ".xlsm"
                If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                lsFilter = lsFilter & "Excelマクロ有効Book, *.xlsm"
            ' CSV
            Case Right(lsWork, 4) = ".csv"
                If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                lsFilter = lsFilter & "CSVファイル, *.csv"
            ' txt
            Case Right(lsWork, 4) = ".txt"
                If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                lsFilter = lsFilter & "テキストァイル, *.txt"
            ' ZIP
            Case Right(lsWork, 4) = ".zip"
                If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                lsFilter = lsFilter & "ZIPファイル, *.zip"
            ' その他
            Case Else
                If Len(lsFilter) > 0 Then lsFilter = lsFilter & C_DELIMITER
                lsFilter = lsFilter & Replace(lsWork, ".", "") & "ファイル" & C_DELIMITER & "*" & lsWork
        End Select
    Next i
    
    If Len(lsFilter) > 0 Then
        lsReturn = lsFilter & C_DELIMITER & lsReturn
    End If
    
EXIT_SEC:
On Error Resume Next

    msGetFileFilter = lsReturn
    
    Exit Function

ERR_SEC:
    lsMsg = "予期せぬエラーが発生しました。" & vbCrLf & _
            "プロシージャ名:msGetFileFilter" & vbCrLf & _
            "エラー番号:" & Err.Number & vbCrLf & _
            "エラー内容:" & Err.Description
    Call gOutputLog(lsMsg)
    Resume EXIT_SEC
End Function

'***************************************************************************
'名称 :GetFolderPath
'機能 :フォルダ選択ダイアログ
'引数 :vsTitle                (I )    String
'   :vsPath                 (I )    String
'戻り値:選択されたPath
'作成 :2018/07/01 kinacco
'更新 :
'***************************************************************************
Public Function GetFolderPath(ByVal vsTitle As String, ByVal vsPath As String) As String
On Error GoTo ERR_SEC
Dim lbRet           As Boolean
Dim lsMsg           As String
Dim lsReturn        As String
Dim lvFile          As Variant
Dim lobjFDialog     As Office.FileDialog

    '--- 初期値セット ---
    lbRet = False
    lsMsg = ""
    lsReturn = ""

    If vsTitle = "" Then vsTitle = "フォルダを選択してください"
    If vsPath = "" Then vsPath = CurrentProject.Path   '(Accessの場合)
    If vsPath = "" Then vsPath = ThisWorkbook.FullName '(Excelの場合)

    '--- FileDialog参照を取得 ---
    Set lobjFDialog = Application.FileDialog(cgs_FileDaialogFolderPicker)
    
    With lobjFDialog
        .AllowMultiSelect = False
        .Title = vsTitle
        .InitialFileName = vsPath
    
        '--- ダイアログ結果取得 ---
        If .Show Then
            '--- 選択されたパス ---
            For Each lvFile In .SelectedItems
                If lsReturn <> "" Then lsReturn = lsReturn & C_DELIMITER
                lsReturn = lsReturn & lvFile
            Next
        End If
    End With
    
    lbRet = True
    
EXIT_SEC:
On Error Resume Next

    Set lobjFDialog = Nothing
    
    GetFolderPath = lsReturn
    
    Exit Function

ERR_SEC:
    lsMsg = "予期せぬエラーが発生しました。" & vbCrLf & _
            "プロシージャ名:GetFolderPath" & vbCrLf & _
            "エラー番号:" & Err.Number & vbCrLf & _
            "エラー内容:" & Err.Description
    Call gOutputLog(lsMsg)
    Resume EXIT_SEC
End Function

「GetFolderPath」はおまけです。APIの方がカッコよく見えますよね。