「ファイルを開く」ダイアログのコードは、書籍やweb上でも多くのサンプルが公開されているので、簡単に入手できると思います。
もちろんそのまま使ってもいいんですが、お決まりの記述を毎回追加することになるため、一緒に部品として使いまわせるように、今回のサンプルはファイル拡張子からフィルタ文字列を自動で組み立てるモジュールもセットにしました。
Excelから呼び出し、Accessから呼び出しの2種類に対応した、コピーしてそのまま使えるコードを紹介します。
2種類のサンプルを掲載します
ファイル選択はOfficeに含まれるFileDialogを呼び出すタイプが主流かと思いますが、APIの「GetOpenFileName」を呼び出すっていうかなりクラシックなやつも未だ現役で稼働しているのもあるので、OfficeオブジェクトとAPI版の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のマクロから呼び出すこともできます。
こんな風に。
ローカル変数の式にこのプロシージャを記述することで、マクロでもファイル選択ダイアログを使用することが可能です。
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の方がカッコよく見えますよね。