Домашняя страница Undo Do Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Готовые решения

МЕНЮ САЙТА
  • 1
  • 2
  • 3

КАТЕГОРИИ РАЗДЕЛА

ОПРОСЫ
Какой версией Excel Вы пользуетесь?
Всего ответов: 35791
Главная » Готовые решения » VBA » Процедуры

Создание пути для сохранения файла
09.04.2016, 00:02
[ Файл-пример (16.1Kb) ]

Процедура проверяет, существует ли путь, к которому обращается Workbooks.SaveAs и если он не существует, создаёт его.

Процедура имеет 5 параметров:

1. FullPath — обязательный. Полный путь для сохранения файла

2. FolderPath — не обязательный. Путь к заведомо существующей папке, значение по умолчанию — ThisWorkbook.Path (путь к папке с макросом)

3. wb — не обязательный. Сохраняемая книга, по умолчанию — ActiveWorkbook. Важно! Параметр представляет собой именно книгу, а не её имя, индекс или кодовое имя. Workbooks("Книга1"), Workbooks(1) или Workbooks(Книга1), но не "Книга1".


4. Form — формат сохранения, не обязательный. По умолчанию файлы форматов .xls, .xlsx, .xlsm, .xlsb сохраняются в том же формате, остальные файлы — в формате .xls или .xlsx, в зависимости от версии Excel

5. PathErr — не обязательный отладочный параметр. Определяет, что делать, если не существует путь, заданный параметром FolderPath. При значении True путь создаётся начиная от диска, при значении False — приложение закрывается.



Sub PathCreator(ByVal FullPath As String, Optional FolderPath As String = "", Optional wb As Workbook = Nothing, Optional Form = "", Optional PathErr As Boolean = True)

Dim PathBody As String

FolderPath = IIf(FolderPath = "", ThisWorkbook.Path, FolderPath)
Set wb = IIf(wb Is Nothing, ActiveWorkbook, wb)
If Form = "" Then
Select Case Right(wb.Name, Len(wb.Name) - InStr(1, wb.Name, ".", vbTextCompare))
Case "xlsx"
Form = xlOpenXMLWorkbook
Case "xlsm"
Form = xlOpenXMLWorkbookMacroEnabled
Case "xlsb"
Form = xlExcel12
Case "xls"
Form = xlExcel8
Case Else
If Application.Version < 12 Then
Form = xlExcel8
Else: Form = xlOpenXMLWorkbook
End If
End Select
End If
On Error Resume Next
PathBody = Dir(FolderPath, vbDirectory)
If PathBody = "" Or InStr(1, FullPath, FolderPath, vbTextCompare) <> 1 Then
If PathErr Then
FolderPath = Left(FolderPath, InStr(1, FolderPath, Application.PathSeparator, vbTextCompare))
Else
MsgBox "Головной путь " & FolderPath & " не существует или не соответствует полному пути"
Application.Quit
End If
End If
Do
Err.Clear
PathBody = Right(FullPath, Len(FullPath) - Len(FolderPath) - 1)
FolderPath = FolderPath & Application.PathSeparator & Left(PathBody, InStr(1, PathBody, Application.PathSeparator, vbTextCompare) - 1)
On Error Resume Next
wb.SaveAs Filename:=FullPath, FileFormat:=Form, CreateBackup:=False
If Err.Number <> 0 Then
Err.Clear
On Error Resume Next
MkDir FolderPath
On Error Resume Next
wb.SaveAs Filename:=FullPath, FileFormat:=Form, CreateBackup:=False
End If
If InStr(1, PathBody, Application.PathSeparator, vbTextCompare) = 0 And Err.Number <> 0 Then
If MsgBox(prompt:="Файл с именем " & PathBody & " уже открыт. Закрыть его?") = vbYes Then
Workbooks(PathBody).Close
wb.SaveAs Filename:=FullPath, FileFormat:=Form, CreateBackup:=False
Else: Application.Quit
End If
End If
Loop While Err.Number <> 0

End Sub
Добавил: StoTisteg | | Теги: VBA
Просмотров: 498 | Рейтинг: 0.0/0
Всего комментариев: 0
Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]
Яндекс цитирования
© 2010-2016 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!