VBA, MS Access MS Access в примерах

Диалог открытия файла (метод FileDialog)


Private Sub cmdTest01_Click()
Dim sFilePuth As String
    'sFilePuth = GetFilePath(CurrentProject.Path, "Book*.xlsx", "Файлы MS Excel", "*.xls; *.xlsx")
    'или
    'sFilePuth = GetFilePath("D:\Temp", , "MS Access Database", "*.mdb; *.accdb" )
    'или
    sFilePuth = GetFilePath(, , "Images", "*.gif; *.jpg; *.jpeg; *.png")
End Sub


Функция:

Public Function GetFilePath(Optional sInitDir As String = "", Optional sFileNameMask As String = "", _
        Optional sFilterName As String = "Любые файлы", Optional sFilterMasks As String = "*.*") As String
'--------------------------------------------------------------------
'es - 09.02.2019 LE 29.03.2023
'Диалог Открытие файла по аргументам:
'   sInitDir       'Опционально = Папка старта диалога - тут по умолчанию папка приложения
'   sFileNameMask  'Опционально = Маска названия файла "Book*.xlsx" и т.п. (!!! Звёздочка ОЧЕНЬ желательна в маске)
'   sFilterName    'Опционально = Название фильтра - тут по умолчанию "Любые файлы"
'   sFilterMasks   'Опционально = Маски фильтра  - тут по умолчанию = "*.*" ("Любые файлы")
'--------------------------------------------------------------------
'Пример:
'   GetFilePath(CurrentProject.Path, "Book*.xlsx", "Файлы MS Excel", "*.xls; *.xlsx")
'   GetFilePath(, "DBStorigeData.*db", "Файлы настроек", "*.mdb")
'--------------------------------------------------------------------

On Error GoTo GetFilePath_Err
    
    If Dir(sInitDir, vbDirectory) = "" Then sInitDir = CurrentProject.Path 'по умолчанию папка приложения
    If Right(sInitDir, 1) <> "" Then sInitDir = sInitDir & "\"  'Папка старта
'--------------------------------------------------------------------
    With Application.FileDialog(1) '1 = msoFileDialogOpen
    ' Заголовок окна
        .Title = "Поиск файла: " & sFileNameMask
        .InitialFileName = sInitDir & sFileNameMask  'Путь с которого стартовать
        .AllowMultiSelect = False                    'Выбор нескольких файлов = OFF
        .Filters.Clear
        .Filters.Add sFilterName, sFilterMasks, 1
        'Поехали!
        .Show
        If .SelectedItems.Count > 0 Then
            GetFilePath = .SelectedItems(1)
        End If
    End With

GetFilePath_Bye:
    Exit Function

GetFilePath_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "в процедуре: GetFilePath", vbCritical, "Error!"
    Resume GetFilePath_Bye
End Function
Назад ToTop
L.E. 10.02.2024
Рейтинг@Mail.ru