Вывод диалоговых окон выбора файла и папки средствами VBA (выбрать файл или папку)

Функции GetFileName и GetFilePath по сути аналогичны, и предназначены для вывода диалогового окна выбора файла
(при этом можно указать стартовую папку для поиска файла, и тип/расширение выбираемого файла)

Функция GetFilenamesCollection позволяет выборать сразу несколько файлов в одной папке.

Функция GetFolderPath работает также, только служит для вывода диалогового окна выбора папки.

Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
                       Optional ByVal InitialPath As String = "c:\") As String
    ' функция выводит диалоговое окно выбора папки с заголовком Title,
    ' начиная обзор диска с папки InitialPath
    ' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
    Dim PS As String: PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show <> -1 Then Exit Function
        GetFolderPath = .SelectedItems(1)
        If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function
 
Sub ПримерИспользования_GetFolderPath()
    ПутьКПапке = GetFolderPath("Заголовок окна", ThisWorkbook.Path)   ' запрашиваем имя папки
    If ПутьКПапке = "" Then Exit Sub    ' выход, если пользователь отказался от выбора папки
    MsgBox "Выбрана папка: " & ПутьКПапке, vbInformation
End Sub

Function GetFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _
                     Optional ByVal InitialPath As String = "c:\", _
                     Optional ByVal FilterDescription As String = "Книги Excel", _
                     Optional ByVal FilterExtention As String = "*.xls*") As String
    ' функция выводит диалоговое окно выбора файла с заголовком Title,
    ' начиная обзор диска с папки InitialPath
    ' возвращает полный путь к выбранному файлу, или пустую строку в случае отказа от выбора
    ' для фильтра можно указать описание и расширение выбираемых файлов
    On Error Resume Next
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
        If .Show <> -1 Then Exit Function
        GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
    End With
End Function
 
Sub ПримерИспользования_GetFilePath()
    ИмяФайла = GetFilePath("Выберите файл Word", , "Документы Word", "*.doc") ' запрашиваем имя файла
    If ИмяФайла = "" Then Exit Sub    ' выход, если пользователь отказался от выбора файла
    MsgBox "Выбран файл: " & ИмяФайла, vbInformation
End Sub

Ниже представлены функции для вызова диалоговых окон выбора файлов и папок средствами VBA.

Функции GetFileName и GetFilePath по сути аналогичны, и предназначены для вывода диалогового окна выбора файла
(при этом можно указать стартовую папку для поиска файла, и тип\расширение выбираемого файла)

Функция GetFilenamesCollection позволяет выборать сразу несколько файлов в одной папке.

Функция GetFolderPath работает аналогично, только служит для вывода диалогового окна выбора папки.

Function GetFileName(Optional ByVal Title As String = "Выберите файл для обработки", _
                     Optional ByVal InitialPath, _
                     Optional ByVal MyFilter As String = "Книги Excel (*.xls*),") As String
    ' функция выводит диалоговое окно выбора папки с заголовком Title,
    ' начиная обзор диска с папки InitialPath
    ' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
    If Not IsMissing(InitialPath) Then
        On Error Resume Next: ChDrive Left(InitialPath, 1)
        ChDir InitialPath    ' выбираем стартовую папку
    End If
    res = Application.GetOpenFilename(MyFilter, , Title, "Открыть")  ' вывод диалогового окна
    GetFileName = IIf(VarType(res) = vbBoolean, "", res)    ' пустая строка при отказе от выбора
End Function
 
Sub ПримерИспользования_GetFileName()
    ИмяФайла = GetFileName("Заголовок окна", ThisWorkbook.Path)   ' запрашиваем имя файла
    ' ===================== другие варианты вызова функции =====================
    ' текстовые файлы, стартовая папка не указана
    '       ИмяФайла = GetFileName("Выберите текстовый файл", , "Текстовые файлы (*.txt),")
    ' файлы любого типа из папки "C:\Windows"
    '       ИмяФайла = GetFileName(, "C:\Windows", "")
    ' ==========================================================================

    If ИмяФайла = "" Then Exit Sub    ' выход, если пользователь отказался от выбора файла
    MsgBox "Выбран файл: " & ИмяФайла, vbInformation
End Sub

Function GetFolderPath(Optional ByVal Title As String = "Выберите папку", _
                       Optional ByVal InitialPath As String = "c:\") As String
    ' функция выводит диалоговое окно выбора папки с заголовком Title,
    ' начиная обзор диска с папки InitialPath
    ' возвращает полный путь к выбранной папке, или пустую строку в случае отказа от выбора
    Dim PS As String: PS = Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        If Not Right$(InitialPath, 1) = PS Then InitialPath = InitialPath & PS
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show <> -1 Then Exit Function
        GetFolderPath = .SelectedItems(1)
        If Not Right$(GetFolderPath, 1) = PS Then GetFolderPath = GetFolderPath & PS
    End With
End Function
 
Sub ПримерИспользования_GetFolderPath()
    ПутьКПапке = GetFolderPath("Заголовок окна", ThisWorkbook.Path)   ' запрашиваем имя папки
    ' ===================== другие варианты вызова функции =====================
    ' стартовая папка не указана, заголовок окна по умолчанию
    '       ПутьКПапке = GetFolderPath
    ' обзор папок начинается с папки "Рабочий стол"
    '       СтартоваяПапка = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    '       ПутьКПапке = GetFolderPath("Выберите папку на рабочем столе", СтартоваяПапка)
    ' ==========================================================================

    If ПутьКПапке = "" Then Exit Sub    ' выход, если пользователь отказался от выбора папки
    MsgBox "Выбрана папка: " & ПутьКПапке, vbInformation
End Sub

Function GetFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _
                     Optional ByVal InitialPath As String = "c:\", _
                     Optional ByVal FilterDescription As String = "Книги Excel", _
                     Optional ByVal FilterExtention As String = "*.xls*") As String
    ' функция выводит диалоговое окно выбора файла с заголовком Title,
    ' начиная обзор диска с папки InitialPath
    ' возвращает полный путь к выбранному файлу, или пустую строку в случае отказа от выбора
    ' для фильтра можно указать описание и расширение выбираемых файлов
    On Error Resume Next
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
        If .Show <> -1 Then Exit Function
        GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
    End With
End Function
 
Sub ПримерИспользования_GetFilePath()
     ИмяФайла = GetFilePath("Выберите файл Word", , "Документы Word", "*.doc") ' запрашиваем имя файла
    ' ===================== другие варианты вызова функции =====================
    ' текстовые файлы, стартовая папка не указана
    '       ИмяФайла = GetFilePath("Выберите текстовый файл", , "Текстовые файлы", "*.txt")
    ' файлы любого типа из папки "C:\Windows"
    '       ИмяФайла = GetFilePath(, "C:\Windows", , "*")
    ' ==========================================================================

    If ИмяФайла = "" Then Exit Sub    ' выход, если пользователь отказался от выбора файла
    MsgBox "Выбран файл: " & ИмяФайла, vbInformation
End Sub

Function GetFilenamesCollection(Optional ByVal Title As String = "Выберите файлы для обработки", _
                             Optional ByVal InitialPath As String = "c:\") As FileDialogSelectedItems
    ' функция выводит диалоговое окно выбора нескольких файлов с заголовком Title,
    ' начиная обзор диска с папки InitialPath
    ' возвращает массив путей к выбранным файлам, или пустую строку в случае отказа от выбора
    With Application.FileDialog(3) ' msoFileDialogFilePicker
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        If .Show <> -1 Then Exit Function
        Set GetFilenamesCollection = .SelectedItems
    End With
End Function
 
Sub ПримерИспользования_GetFilenamesCollection()
    Dim СписокФайлов As FileDialogSelectedItems
    Set СписокФайлов = GetFilenamesCollection("Заголовок окна", ThisWorkbook.Path)   ' выводим окно выбора
    ' ===================== другие варианты вызова функции =====================
    ' стартовая папка не указана, заголовок окна по умолчанию
           Set СписокФайлов = GetFilenamesCollection
    ' обзор файлов начинается с папки "Рабочий стол"
           СтартоваяПапка = CreateObject("WScript.Shell").SpecialFolders("Desktop")
           Set СписокФайлов = GetFilenamesCollection("Выберите файлы на рабочем столе", СтартоваяПапка)
    ' ==========================================================================

    If СписокФайлов Is Nothing Then Exit Sub  ' выход, если пользователь отказался от выбора файлов
    For Each File In СписокФайлов
        Debug.Print File
    Next
End Sub

Ещё один вариант кода (который я использую) для выбора файла
Его отличие - функция запоминает папку, из которой последний раз выбирался файл,
и при повторном запуске диалогового окна выбора файла,
обзор папок будет начат с той папки, откуда последний раз был взят файл.

Sub AttachFile_test()    ' пример использования
    Filename$ = GetFilePath()
    If Filename$ = "" Then Exit Sub
    MsgBox "Выбран файл: " & Filename$
End Sub
 
Function GetFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _
                     Optional ByVal InitialPath As String = "c:\", _
                     Optional ByVal FilterDescription As String = "Файлы счетов", _
                     Optional ByVal FilterExtention As String = "*.*") As String
    On Error Resume Next
    With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = "Выбрать": .Title = Title:
        .InitialFileName = GetSetting(Application.Name, "GetFilePath", "folder", InitialPath)
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
        If .Show <> -1 Then Exit Function
        GetFilePath = .SelectedItems(1)
        folder$ = Left(.SelectedItems(1), InStrRev(.SelectedItems(1), "\"))
        SaveSetting Application.Name, "GetFilePath", "folder", folder$
    End With
End Function

222207 просмотров

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Гость, 15 Дек 2011 - 13:50.#1

А можно ли сделать так, что если пользователь ввёл в поле "имя файла" что-то сам, а такого файла нет в данной папке, то он создавался автоматически??? Спасибо.

Lambert, 28 Июн 2011 - 15:59.#2

Добрый день!

Все чудесно работает для Excel 2007 и 2003. А как сделать выбор файла (именно файла, а не папки) для Excel 97? Если использовать BrowseForFolder, то какой должен быть синтаксис? У Павла Климова я этого не нашел.

Спасибо!

Гость, 12 Май 2011 - 18:24.#3

Спасибо.
Программа с вызовом BrowseForFolder уже есть )) Она дает создавать новую папку.
Но хотелось бы еще иметь возможность
- поиска папки по имени
- задания стартовой папки
подскажите, пожалуйста, можно ли это сделать в 2000

Игорь (администратор сайта), 11 Май 2011 - 22:52.#4

что посоветуете для Excel 2000 ?

Павел Климов на своём сайте msoffice.nm.ru уже дал совет - остаётся лишь процитировать:

Объект FileDialog впервые появился в Microsoft Excel XP
Для выбора папки в более ранних версиях Excel (97, 2000) используйте следующий код:

Sub test()
    Set wshell = CreateObject("Shell.Application")
    On Error Resume Next 'игнорируем ошибку, если нажата Cancel
    Set iPath = wshell.BrowseForFolder(&H0, " Выберите папку....", &H1, 17)
 
    If Not iPath Is Nothing Then
        'FolderPath = iPath.Self.Path 'вариант для WINNT
        FolderPath = iPath.Items.Item.Path    'универсальный вариант для WIN9х/NT
    Else
       Exit Sub 'нажата Cancel
    End If
 
    MsgBox "Выбрана папка: " & FolderPath, vbInformation
End Sub

Гость, 11 Май 2011 - 13:08.#5

Добрый день!
В Excel 2000 на оператор

With Application.FileDialog(msoFileDialogFolderPicker)

выдается ошибка 438.
нужно диалоговое окно выбора папки с возможностью
- поиска по имени
- создания новой папки
- задания стартовой папки
что посоветуете для Excel 2000 ?

JRV, 2 Май 2011 - 01:02.#6

с диалогами работал, но здесь более элегантно реализовано

Дмитрий, 9 Мар 2011 - 18:49.#7

функция GetFileName отлично работает. Спасибо.
вместо MsgBox вставил у себя Application.Workbooks.Open ИмяФайла и порядок.
----------
Excel 2007

Отправить комментарий

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.

Вывод диалоговых окон выбора файла и папки средствами VBA (выбрать файл или папку)

Комментарии

Настройки просмотра комментариев

Отправить комментарий

НАДСТРОЙКИ ДЛЯ EXCEL