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

Никаких дополнительных библиотек не требуется и стандартные Константы 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

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

Public Function OpenFileDialog(ByVal sInitDir As String, sFlNameOrMask As String, _

Optional sFltName As String = "All Files (*.*)", Optional sFltExtensions As String = "*.*") As String

'es - 23.07.2015 - v001

'Диалог открытия файла по парамеррам:

' sInitDir = Стартовая папка со слешем на конце(желательно), типа: CurrentProject.Path & "\"

' sFlNameOrMask = Название или маска поиска файла

' sFltName = Название применяемого фильтра - по умолч: All Files (*.*)

' sFltExtensions = Расширения применяемого фильтра - по умолч: *.* _

что то типа "*.gif; *.jpg; *.jpeg" через точку с запятой

'--------------------------------------------------------------------

'Пример эксплуотации:

' ?OpenFileDialog (CurrentProject.Path & "\", "ReportsDB-2015.*db", "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) '

' Заголовок окна

.Title = "Поиск файла: " & sFlNameOrMask

.InitialFileName = sInitDir & sFlNameOrMask 'Папка с которой стартовать

.AllowMultiSelect = False 'Выбор нескольких файлов = OFF

.Filters.Clear

.Filters.Add sFlNameOrMask, sFltExtensions, 1

i = .Show '

If i = 0 Then Exit Function

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