開く・保存・選択ダイアログの使い方 | VBA

Private Sub Button_Open_Click()

    Dim ret As Integer
    Dim FileName As String
    
    ret = OpenDialog("", "CSVファイル (*.csv),*.csv,テキストファイル (*.txt),*.txt", FileName)
    If ret = 0 Then
        Range("G4") = FileName
    Else
        Range("G4") = "キャンセル"
    End If

End Sub

Private Sub Button_Save_Click()

    Dim ret As Integer
    Dim FileName As String
    
    ret = SaveDialog("", "", "CSVファイル (*.csv),*.csv,テキストファイル (*.txt),*.txt", FileName)
    If ret = 0 Then
        Range("G8") = FileName
    Else
        Range("G8") = "キャンセル"
    End If

End Sub

Private Sub Button_Select_Click()

    Dim ret As Integer
    Dim SelectDir As String
    
    ret = SelectDialog("", SelectDir)
    If ret = 0 Then
        Range("G12") = SelectDir
    Else
        Range("G12") = "キャンセル"
    End If

End Sub

'サーバー上のフォルダーを指定できるよう SetCurrentDirectory を使用する
#If VBA7 Then
    Declare PtrSafe Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long
#Else
    Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal CurrentDir As String) As Long
#End If

'最後に開いたフォルダー
Private Last_OpenDir As String

'最後に保存したフォルダー
Private Last_SaveDir As String

'最後に選択したフォルダー
Private Last_SelectDir As String

'*******************************************************************************
' ファイルを開くダイアログ
'  input  : IniDir = 初期表示フォルダー (空なら最後に開いたフォルダー)
'           Filter = ファイルフィルター (例:"CSVファイル (*.csv),*.csv")
'  output : FileName = ファイル名
'  return : 0=成功 / 1=キャンセル
'*******************************************************************************
Public Function OpenDialog(IniDir As String, Filter As String, _
                           FileName As String) As Integer

    Dim OpenDir As String

    '初期表示フォルダーの設定
    If IniDir = "" Then
        If Last_OpenDir = "" Then
            '初回はExcelファイルのあるフォルダー
            Last_OpenDir = ThisWorkbook.path
        End If
        OpenDir = Last_OpenDir
    Else
        OpenDir = IniDir
    End If
    SetCurrentDirectory OpenDir

    FileName = Application.GetOpenFilename(FileFilter:=Filter)
    If FileName = "False" Then
        OpenDialog = 1
        Exit Function
    End If

    'フォルダーを記憶
    Last_OpenDir = Left(FileName, InStrRev(FileName, "\") - 1)

    OpenDialog = 0
End Function

'*******************************************************************************
' ファイルを開くダイアログ (複数選択版)
'  input  : IniDir = 初期表示フォルダー (空なら最後に開いたフォルダー)
'           Filter = ファイルフィルター (例:"CSVファイル (*.csv),*.csv")
'  output : FileName = 複数ファイル名
'  return : 0=成功 / 1=キャンセル
'*******************************************************************************
Public Function OpenDialog_Multi(IniDir As String, Filter As String, _
                                 FileName As Variant) As Integer

    Dim OpenDir As String

    '初期表示フォルダーの設定
    If IniDir = "" Then
        If Last_OpenDir = "" Then
            '初回はExcelファイルのあるフォルダー
            Last_OpenDir = ThisWorkbook.path
        End If
        OpenDir = Last_OpenDir
    Else
        OpenDir = IniDir
    End If
    SetCurrentDirectory OpenDir

    FileName = Application.GetOpenFilename(FileFilter:=Filter, _
                                           MultiSelect:=True)
    If Not IsArray(FileName) Then
        OpenDialog_Multi = 1
        Exit Function
    End If

    'フォルダーを記憶
    Last_OpenDir = Left(FileName(1), InStrRev(FileName(1), "\") - 1)

    OpenDialog_Multi = 0
End Function

'*******************************************************************************
' 名前を付けて保存ダイアログ
'  input  : IniDir = 初期表示フォルダー (空なら最後に保存したフォルダー)
'           IniFileName = 初期表示ファイル名 (空でもいい)
'           Filter = ファイルフィルター (例:"CSVファイル (*.csv),*.csv")
'  output : FileName = ファイル名
'  return : 0=成功 / 1=キャンセル
'*******************************************************************************
Public Function SaveDialog(IniDir As String, IniFileName As String, _
                           Filter As String, FileName As String) As Integer

    Dim SaveDir As String

    '初期表示フォルダーの設定
    If IniDir = "" Then
        If Last_SaveDir = "" Then
            '初回はExcelファイルのあるフォルダー
            Last_SaveDir = ThisWorkbook.path
        End If
        SaveDir = Last_SaveDir
    Else
        SaveDir = IniDir
    End If
    SetCurrentDirectory SaveDir

    FileName = Application.GetSaveAsFilename(InitialFileName:=IniFileName, _
                                             FileFilter:=Filter)
    If FileName = "False" Then
        SaveDialog = 1
        Exit Function
    End If

    'フォルダーを記憶
    Last_SaveDir = Left(FileName, InStrRev(FileName, "\") - 1)

    SaveDialog = 0

End Function

'**********************************************************************
' フォルダー選択ダイアログ
'  input  : IniDir = 初期表示フォルダー (空だと最後に開いたフォルダーになる)
'  output : SelectDir = 選択したフォルダー
'  return : 0=成功 / 1=キャンセル
'**********************************************************************
Public Function SelectDialog(IniDir As String, SelectDir As String) As Integer

    Dim OpenDir As String

    '初期表示フォルダーの設定
    If IniDir = "" Then
        '初期表示フォルダーの指定なし > 前回開いたフォルダー
        If Last_SelectDir = "" Then
            '初回はExcelファイルのあるフォルダー
            Last_SelectDir = ThisWorkbook.path
        End If
        OpenDir = Last_SelectDir
    Else
        OpenDir = IniDir
    End If
    OpenDir = OpenDir + "\"
    SetCurrentDirectory OpenDir

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダーを選択"
        .ButtonName = "選択"
        .InitialFileName = OpenDir
        If .Show = True Then
            SelectDir = .SelectedItems(1)
        Else
            SelectDialog = 1
            Exit Function
        End If
    End With

    'フォルダーを記憶
    Last_SelectDir = SelectDir

    SelectDialog = 0

End Function