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

Диалог открытия Файла или Папки средствами MS Access (Application.FileDialog)


Никаких дополнительных библиотек не требуется и стандартные Константы FileDialog - Подходят.

'--------------------------------------------------------------------
'Константы MSO - Application.FileDialog:
'   1 = msoFileDialogOpen
'   2 = msoFileDialogSaveAs
'   3 = msoFileDialogFilePicker
'   4 = msoFileDialogFolderPicker
'--------------------------------------------------------------------


Диалог открытия Папки

Private Sub cmdOpenArcFolder_Click()
' Диалог открытия Папки
'--------------------------------------------------------------------
Dim sFolderPath As String
Dim result As Integer
'
'--------------------------------------------------------------------
On Error GoTo cmdOpenArcFolder_Click_Err
    With Application.FileDialog(4) '   4 = msoFileDialogFolderPicker
        .Title = "Выбирите Папку для хранения архивов БД ..."
    
        .InitialFileName = CurrentProject.Path 'Папка с которой стартовать
        .AllowMultiSelect = False
        result = .Show
    
        If result = 0 Then Exit Sub
        sFolderPath = Trim(.SelectedItems.Item(1))
    End With
    
    If Dir(sFolderPath, vbDirectory) = "" Then
        PrepareFolders sFolderPath
        WriteINI "Путь к Архивам", sFolderPath, "АРХИВАЦИЯ"
    End If
    Me!txtArkPath = sFolderPath

cmdOpenArcFolder_Click_Bye:
    Exit Sub

cmdOpenArcFolder_Click_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "в процедуре: cmdOpenArcFolder_Click", vbCritical, "Error!"
    Resume cmdOpenArcFolder_Click_Bye
    
End Sub



Диалог открытия Файла(ов)

Частный случай.

Private Sub cmdPathToNewDB_Click()
'--------------------------------------------------------------------
'es - 23.07.2015 - V002
'Поиск ReportsDB.mdb в папке приложения ... по нажатию кнопки
'--------------------------------------------------------------------
Dim InitDir As String
Dim strFileName As String
Dim s As String
Dim i As Integer

On Error GoTo cmdPathToNewDB_Click_Err

    InitDir = CurrentProject.Path & "\"
    strFileName = "ReportsDB-2015.*db"   'Звёздочка для БОЛЕЕ точного отбора ... :)
'--------------------------------------------------------------------
    With Application.FileDialog(1) '
    ' Заголовок окна
        .Title = "Поиск файла: " & strFileName
        .InitialFileName = InitDir & strFileName   'Папка с которой стартовать
        .AllowMultiSelect = False                  'Выбор нескольких файлов = OFF
        .Filters.Clear
        .Filters.Add "MS Access Database", "*.mdb; *.accdb", 1
        'Ещё варианты :
            '.Filters.Add "Images", "*.gif; *.jpg; *.jpeg" ', 2 '
            '.Filters.Add "All Files (*.*)", "*.*" ', 3
        'Поехали!
        i = .Show
    
        If i = 0 Then
            s = ""
        Else
            s = Trim(.SelectedItems.Item(1))
        End If
    End With

'Записываем ...
    Me!txtPathToNewDB = s
    'INIWrite "Путь к Новой Базе", s, "ИМПОРТ"

cmdPathToNewDB_Click_Bye:
    Exit Sub

cmdPathToNewDB_Click_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "в процедуре: cmdPathToNewDB_Click", vbCritical, "Error!"
    Resume cmdPathToNewDB_Click_Bye
End Sub



На случай повторений - слепил универсальный вариант:
Пример применения:

Dim str As String
    str = "Ко*_be.*" 'Маска поиска файла
'Открытие диалога пути к файлу
    str = OpenFileDialog(CurrentProject.Path, str, "MS Access DataBase", "*.accdb")
    If Len(str) < 3 Then Exit Sub
    Me!txtDBPath = str




Public Function OpenFileDialog(ByVal sInitDir As String, Optional sFlNameOrMask As String = "", _
        Optional sFltName As String = "All Files (*.*)", Optional sFltExtensions As String = "*.*") As String
'es - 23.07.2015 - LE: 13.07.2018
'Диалог открытия файла по парамеррам:
'   sInitDir        = Стартовая папка со слешем на конце(желательно), типа: CurrentProject.Path & "\"
'   sFlNameOrMask   = Название или маска поиска файла, yапример "Реквизиты*" - по умолч: "" (Пустая строка)
'   sFltName        = Название применяемого фильтра - по умолч: All Files (*.*)
'   sFltExtensions  = Расширения применяемого фильтра - по умолч: *.* _
                      Например: "*.gif; *.jpg; *.jpeg" (через точку с запятой)
'--------------------------------------------------------------------
'Пример эксплуатации:
'   sPath = OpenFileDialog (CurrentProject.Path, "ReportsDB*", "MS Access Database", "*.mdb; *.accdb")
'--------------------------------------------------------------------
Dim i As Integer
'--------------------------------------------------------------------
On Error GoTo OpenFileDialog_Err
    If Right(sInitDir, 1) <> "\" Then sInitDir = sInitDir & "\"
    
    With Application.FileDialog(1) 'msoFileDialogOpen
    ' Заголовок окна
        .Title = "Поиск файла: " & sFlNameOrMask
        .InitialFileName = sInitDir & sFlNameOrMask  'Папка с которой стартовать
        .AllowMultiSelect = False                    'Выбор нескольких файлов = OFF
        .Filters.Clear
        .Filters.Add sFltName, sFltExtensions, 1
        '.Filters.Add "All files", "*.*", 2 '(опционально) пунктом #2 - возможность выбора любых файлов
        
        i = .Show '
        If i = 0 Then Exit Function '0 = Отмена или -1 = Выбор сделан
        OpenFileDialog = Trim(.SelectedItems.Item(1))

    End With

OpenFileDialog_Bye:
    Exit Function

OpenFileDialog_Err:
    MsgBox "Ошибка " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "в процедуре: OpenFileDialog", vbCritical, "Error!"
    Resume OpenFileDialog_Bye

End Function


Назад ToTop
L.E. 22.08.2024
Рейтинг@Mail.ru