TopPicLogo TopPicText

Диалог открытия Файла или Папки средствами 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

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