Vba helper

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

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