Как сделать папки как в виндовс 8

Как сделать папки как в виндовс 8

Как сделать папки как в виндовс 8

Как сделать папки как в виндовс 8

Как сделать папки как в виндовс 8

Функции 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

Комментарии

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

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

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


Источник: http://excelvba.ru/code/GetFileOrFolderPath


“-5-10 Как сделать папки как в виндовс 8