|
|
Диалог открытия Файла или Папки средствами MS Access (Application.FileDialog)
Никаких дополнительных библиотек не требуется и стандартные Константы FileDialog - Подходят.
Диалог открытия Папки
Private Sub cmdOpenArcFolder_Click()
Dim sFolderPath As String
Dim result As Integer
On Error GoTo cmdOpenArcFolder_Click_Err
With Application.FileDialog(4)
.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()
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
.Filters.Clear
.Filters.Add "MS Access Database", "*.mdb; *.accdb", 1
i = .Show
If i = 0 Then
s = ""
Else
s = Trim(.SelectedItems.Item(1))
End If
End With
Me!txtPathToNewDB = 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
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 sFltName, sFltExtensions, 1
'.Filters.Add "All files", "*.*", 2 '(опционально) пунктом #2 - возможность выбора любых файлов
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
|
|