Ниже представлены функции для вызова диалоговых окон выбора файлов и папок средствами 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
|
|||
Комментарии
У меня, к счастью (именно, к счастью), тоже нет мака.
Написал небольшую примитивную базку (сам не программист, просто немного умею и быстро учусь при необходимости).
Попросили оптимизировать под мак, т.к. у одного из пользователей яблочный друг. На Windows всё прекрасно работает, а вот на маке форма открывается, на лист данные заносятся без проблем, но эта кнопка не работает, диалоговое окно не открывает, наверняка, и папки не создаёт.
Может из-за того, что там стартовая папка указана "C:\"?
По самому коду есть нарекания, явные ошибки?
Существуют ли альтернативные команды создания директорий и вывода диалоговых окон?
Спасибо!
Здравствуйте, Виктор.
К сожалению, помочь в этом вопросе не смогу, - ибо не являюсь счастливым обладателем Mac-а, и, соответственно, протестировать код на Макинтоше нет никакой возможности.
Доброго времени!
Интересует вопрос, как этот код оптимизировать под Office for mac?
Кнопка открывает диалоговое окно, в нём выбирается нужный файл, при нажатии "открыть", по предустановленному шаблону создаётся папка, в неё копируется выбранный файл, диалоговое окно закрывается. Этот код работает на Windows.
Private Sub Photoprot_bef_oper_but_Click()
File_Path = GetFilePath
St = ActiveWorkbook.Path
SrcFile = File_Path
DestFile = St & "\" & "MRI_CT_Rtg" & "\" & Name_.Text & "_" & Date_hospit.Text & "\" & "6. Фото-видеопротокол" & "_" & Photoprot_bef_oper.Text & "\"
On Error Resume Next
MkDir (St & "\" & "MRI_CT_Rtg" & "\")
MkDir (St & "\" & "MRI_CT_Rtg" & "\" & Name_.Text & "_" & Date_hospit.Text & "\")
MkDir (St & "\" & "MRI_CT_Rtg" & "\" & Name_.Text & "_" & Date_hospit.Text & "\" & "6. Фото-видеопротокол" & "_" & Photoprot_bef_oper.Text)
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile SrcFile, DestFile
End Sub
Function GetFilePath(Optional ByVal Title As String = "Выберите файл для загрузки", _
Optional ByVal InitialPath As String = "C:\") As String
On Error Resume Next
With Application.FileDialog(msoFileDialogOpen)
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
If .Show <> -1 Then Exit Function
GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
End With
End Function
Необходимо, что бы работало как на винде, так и на мак.
Спасибо!
Сам на свой вопрос ответил )
Dim NameRateFile As String
Dim AskMsg, StyleAskMsg, TitleAskMsg, HelpAskMsg, CtxtAskMsg, ResponseAskMsg, MyStringAskMsg
Dim AskMsg1, StyleAskMsg1, TitleAskMsg1, HelpAskMsg1, CtxtAskMsg1, ResponseAskMsg1, MyStringAskMsg1
Dim NewFileName As String
Dim fso As FileSystemObject
Dim f1, f2 As File
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("C9:C10"), Target) Is Nothing Then
UserForm1.Show
End If
If Not Application.Intersect(Range("C17:C17"), Target) Is Nothing Then
'MsgBox "Âûäåëåíà ÿ÷åéêà: "
NameRateFile = GetFileName("Çàãîëîâîê îêíà", ThisWorkbook.Path) ' çàïðàøèâàåì èìÿ ôàéëà
If NameRateFile = "" Then
NewFileName = ActiveSheet.Name
Range("C17:C18") = ""
AskMsg = "Ñîçäàòü ôàéë " + NewFileName + " â òåêóùåé äèðåêòîðèè ?" ' Define message.
StyleAskMsg = vbYesNo + vbQuestion + vbDefaultButton2 ' Define buttons
TitleAskMsg = "Ôàéë íå íàéäå" ' Define title.
HelpAskMsg = "DEMO.HLP" ' Define Help file.
CtxtAskMsg = 1000 ' Define topic
ResponseAskMsg = MsgBox(AskMsg, StyleAskMsg, TitleAskMsg, HelpAskMsg, CtxtAskMsg)
AskMsg1 = "Ïåðåçàïèñàòü ñóùåñòâóþùèé ôàéë " + NewFileName + " â òåêóùåé äèðåêòîðèè ?" ' Define message.
StyleAskMsg1 = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons
TitleAskMsg1 = "ÏÅÐÅÇÀÏÈÑÜ ÔÀÉËÀ" ' Define title.
HelpAskMsg1 = "DEMO.HLP" ' Define Help file.
CtxtAskMsg1 = 1000 ' Define topic
If ResponseAskMsg = vbYes Then ' User chose Yes.
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next: ResponseAskMsg1 = MsgBox(AskMsg1, StyleAskMsg1, TitleAskMsg1, HelpAskMsg1, CtxtAskMsg1)
If ResponseAskMsg1 = vbYes Then
Set f2 = fso.CreateTextFile(NewFileName + ".txt", True)
End If
If ResponseAskMsg1 = vbNo Then
MsgBox "Ôàéë íå âûáðàí è íå ñîçäàí !"
Exit Sub
End If
Set f1 = fso.CreateTextFile(NewFileName + ".txt", False)
f1.Close
NameRateFile = ThisWorkbook.Path + "\" + NewFileName + ".txt"
Else ' User chose No.
MsgBox "Ôàéë íå âûáðàí è íå ñîçäàí !"
Exit Sub
End If
End If ' âûõîä, åñëè ïîëüçîâàòåëü îòêàçàëñÿ îò âûáîðà ôàéëà
MsgBox "Âûáðàí ôàéë: " & NameRateFile, vbInformation
Range("C17:C17") = NameRateFile
End If
End Sub
А можно ли сделать так, что если пользователь ввёл в поле "имя файла" что-то сам, а такого файла нет в данной папке, то он создавался автоматически??? Спасибо.
Добрый день!
Все чудесно работает для Excel 2007 и 2003. А как сделать выбор файла (именно файла, а не папки) для Excel 97? Если использовать BrowseForFolder, то какой должен быть синтаксис? У Павла Климова я этого не нашел.
Спасибо!
Спасибо.
Программа с вызовом BrowseForFolder уже есть )) Она дает создавать новую папку.
Но хотелось бы еще иметь возможность
- поиска папки по имени
- задания стартовой папки
подскажите, пожалуйста, можно ли это сделать в 2000
Павел Климов на своём сайте msoffice.nm.ru уже дал совет - остаётся лишь процитировать:
Добрый день!
В Excel 2000 на оператор
With Application.FileDialog(msoFileDialogFolderPicker)
выдается ошибка 438.
нужно диалоговое окно выбора папки с возможностью
- поиска по имени
- создания новой папки
- задания стартовой папки
что посоветуете для Excel 2000 ?
с диалогами работал, но здесь более элегантно реализовано
функция GetFileName отлично работает. Спасибо.
вместо MsgBox вставил у себя Application.Workbooks.Open ИмяФайла и порядок.
----------
Excel 2007
Отправить комментарий