Подскажите пожалуйста по коду, макрос выделяет лист в отдельную книгу, сохраняет её и отправляет через Outlook, но сохранение работает некорректно, а именно: дает выбрать папку куда сохранить файл с листом, но после выбора всё равно сохранение файла происходит в папку где находится начальная книга
Код
Sub EXP() 'Макрос сохранения листа и отправки
Dim objOutlookApp As Object, objMail As Object
Dim wb As Workbook
Dim sAttachment As String
Application.ScreenUpdating = False
On Error Resume Next
'пробуем подключиться к Outlook, если он уже открыт
Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear 'Outlook закрыт, очищаем ошибку
If objOutlookApp Is Nothing Then
Set objOutlookApp = CreateObject("Outlook.Application")
End If
Set objMail = objOutlookApp.CreateItem(0) 'создаем новое сообщение
'если не получилось создать приложение или экземпляр сообщения - выходим
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
Application.DisplayAlerts = False
Set wb = ActiveWorkbook
sAttachment = wb.Path & "\" & ActiveSheet.Name & ".xlsx"
ActiveSheet.Copy
With ActiveWorkbook
.sToSave = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
.SaveAs sAttachment, xlOpenXMLWorkbook
.Close False
End With
Application.DisplayAlerts = True
'создаем сообщение
With objMail
.To = Range("A3").Value 'адрес получателя
.Subject = ActiveSheet.Name 'тема сообщения
'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
If sAttachment <> "" Then
If Dir(sAttachment, 16) <> "" Then
.Attachments.Add sAttachment 'просто вложение
End If
End If
.Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
End With
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
End Sub
И Вам здравствуйте в 25 строке Вы вызываете стандартное диалоговое окно Сохранить как, получаете в нем путь по которому нужно сохранять файл, но в 26 строке сохраняете по пути sAttachment = wb.Path & "\" & ActiveSheet.Name & ".xlsx", т.е. в папку активной книги.
bigorq, Благодарю за ответ. Я поправил код, теперь работает как надо
Код
Sub EXP() 'Макрос сохранения листа и отправки
Dim objOutlookApp As Object, objMail As Object
Dim wb As Workbook
Dim sAttachment As String
Application.ScreenUpdating = False
On Error Resume Next
'пробуем подключиться к Outlook, если он уже открыт
Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear 'Outlook закрыт, очищаем ошибку
If objOutlookApp Is Nothing Then
Set objOutlookApp = CreateObject("Outlook.Application")
End If
Set objMail = objOutlookApp.CreateItem(0) 'создаем новое сообщение
'если не получилось создать приложение или экземпляр сообщения - выходим
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
Application.DisplayAlerts = False
Set wb = ActiveWorkbook
sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
ActiveSheet.Copy
With ActiveWorkbook
.SaveAs sAttachment, xlOpenXMLWorkbook
.Close False
End With
Application.DisplayAlerts = True
'создаем сообщение
With objMail
.To = Range("A3").Value 'адрес получателя
.Subject = ActiveSheet.Name 'тема сообщения
'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
If sAttachment <> "" Then
If Dir(sAttachment, 16) <> "" Then
.Attachments.Add sAttachment 'просто вложение
End If
End If
.Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
End With
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
End Sub
в строке 22 было прописано сохранять в текущую папку. добавил туда диалоговое окно сохранять как и тогда заработало. строку 25 удалил.
Валерий, это не команда, это переменная, в которую прописываем путь для сохранения файла. В первом случае вычисляя его из пути активной книги, во втором с помощью окна сохранить как.
bigorq, нет конечно) просто логику пытаюсь понять, в начале в переменную записано "как сохранять", а потом написано "сохраняй так как написано в переменной".
почему просто нельзя выполнить сразу, "сохраняй так как написал".
Валерий, можно и сразу после SaveAs путь прописать куда будем сохранять.Наберите в поисковике vba saveas и читайте доки по методу и как им пользоваться
Sub EXP() 'Макрос сохранения листа и отправки
Dim objOutlookApp As Object, objMail As Object
Dim wb As Workbook
Dim sAttachment As String
Application.ScreenUpdating = False
On Error Resume Next
'пробуем подключиться к Outlook, если он уже открыт
Set objOutlookApp = GetObject(, "Outlook.Application")
Err.Clear 'Outlook закрыт, очищаем ошибку
If objOutlookApp Is Nothing Then
Set objOutlookApp = CreateObject("Outlook.Application")
End If
Set objMail = objOutlookApp.CreateItem(0) 'создаем новое сообщение
'если не получилось создать приложение или экземпляр сообщения - выходим
If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
Application.DisplayAlerts = False
Set wb = ActiveWorkbook
sAttachment = Application.GetSaveAsFilename(InitialFileName:=wb.Path & "\" & ActiveSheet.Name & ".xlsx")
ActiveSheet.Copy
With ActiveWorkbook
.sToSavePath = Application.GetSaveAsFilename(InitialFileName:=sAttachment)
.SaveAs sAttachment, xlOpenXMLWorkbook
.Close False
End With
Application.DisplayAlerts = True
'создаем сообщение
With objMail
.To = Range("A3").Value 'адрес получателя
.Subject = ActiveSheet.Name 'тема сообщения
'добавляем вложение, если файл по указанному пути существует(dir проверяет это)
If sAttachment <> "" Then
If Dir(sAttachment, 16) <> "" Then
.Attachments.Add sAttachment 'просто вложение
End If
End If
.Display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
End With
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
End Sub
Добрый день! Подскажите пожалуйста, после перехода на Excel 2019 / Windows 10, макрос перестал в диалоговое окно сохранения файла автоматически подставлять имя файла, исходя из названия листа. в чем может быть дело? И пробовал прописть так: