VBでファイルを開く・保存ダイアログ

WindowsAPIを使用する

#If VBA7 Then
    Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private 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
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As LongPtr
        lpTemplateName As String
    End Type
#Else
    Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private 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
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
    End Type
#End If

Private Const OFN_HIDEREADONLY = &H4        '読み取り専用オプションを非表示
Private Const OFN_FILEMUSTEXIST = &H1000    'ファイルの存在確認

Public Function fileOpenDialog(ByVal hwnd As Long, ByVal initialDirectory As String, ByVal initialFileName As String, ParamArray fileFilters() As Variant) As String
    Dim openFile As OPENFILENAME
    Dim result As Long
    fileOpenDialog = ""
    openFile.lpstrFilter = createFilterString(fileFilters)
    openFile.nFilterIndex = 1
    openFile.hwndOwner = hwnd
    openFile.lpstrFile = String(201, 0)
    #If VBA7 Then
        openFile.nMaxFile = LenB(openFile.lpstrFile) - 1
        openFile.lStructSize = LenB(openFile)
    #Else
        openFile.nMaxFile = Len(openFile.lpstrFile) - 1
        openFile.lStructSize = Len(openFile)
    #End If
    openFile.lpstrFileTitle = openFile.lpstrFile
    openFile.nMaxFileTitle = openFile.nMaxFile
    openFile.lpstrInitialDir = initialDirectory
    openFile.lpstrFile = initialFileName & String(201 - Len(initialFileName), Chr(0))
    openFile.lpstrTitle = "ファイルを開く"
    openFile.flags = OFN_HIDEREADONLY + OFN_FILEMUSTEXIST
    result = GetOpenFileName(openFile)
    If result <> 0 Then
        fileOpenDialog = Trim(Left(openFile.lpstrFile, InStr(1, openFile.lpstrFile, vbNullChar) - 1))
    End If
End Function

Public Function fileSaveDialog(ByVal hwnd As Long, ByVal initialDirectory As String, ByVal initialFileName As String, ByVal fileExtension As String) As String
    Dim openFile As OPENFILENAME
    Dim result As Long
    fileSaveDialog = ""
    openFile.lpstrFilter = fileExtension & "ファイル (*." & fileExtension & ")" & Chr(0) & "*." & fileExtension
    openFile.nFilterIndex = 1
    openFile.hwndOwner = hwnd
    openFile.lpstrFile = String(201, 0)
    #If VBA7 Then
        openFile.nMaxFile = LenB(openFile.lpstrFile) - 1
        openFile.lStructSize = LenB(openFile)
    #Else
        openFile.nMaxFile = Len(openFile.lpstrFile) - 1
        openFile.lStructSize = Len(openFile)
    #End If
    openFile.lpstrFileTitle = openFile.lpstrFile
    openFile.nMaxFileTitle = openFile.nMaxFile
    openFile.lpstrInitialDir = initialDirectory
    openFile.lpstrFile = initialFileName & String(201 - Len(initialFileName), Chr(0))
    openFile.lpstrDefExt = fileExtension
    openFile.lpstrTitle = "ファイルの保存"
    openFile.flags = 0
    result = GetSaveFileName(openFile)
    If result <> 0 Then
        fileSaveDialog = Trim(Left(openFile.lpstrFile, InStr(1, openFile.lpstrFile, vbNullChar) - 1))
    End If
End Function

Private Function createFilterString(ByVal fileFilters As Variant) As String
    Dim filterString As String
    filterString = ""
    For i = 0 To UBound(fileFilters)
        Dim filter() As String
        filter = Split(fileFilters(i), "|")
        If Len(filterString) > 0 Then
            filterString = filterString & Chr(0)
        End If
        If UBound(filter) = 1 Then
            filterString = filterString & filter(0) & Chr(0) & filter(1)
        ElseIf UBound(filter) = 0 Then
            filterString = filterString & filter(0)
        End If
    Next i
    createFilterString = filterString
End Function