Добрый день! Подскажите пожалуйста, после перехода на Excel 2019 / Windows 10, макрос перестал в диалоговое окно сохранения файла автоматически подставлять имя файла, исходя из названия листа. в чем может быть дело? часть кода, относящегося к сохранению файла
Код
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
а точку перед sToSavePath убирать не пробовали? Я вроде уже указывал Вам на эту ошибку в одной из прошлых тем. Плюс непонятно зачем два раза один и тот же диалог вызывать...
Валерий написал: отстуствие / наличие точки никак не повлияло
даже не сомневаюсь. Потому что уверен, что где-то ранее в коде используется On Error Resume Next, которая подавляет ошибку на этой строке. ибо я точно знаю, что у объекта ActiveWorkbook нет свойства или метода sToSavePath, а это просто придуманная мной переменная для хранения пути сохранения файлов.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Дмитрий(The_Prist) Щербаков написал: Потому что уверен, что где-то ранее в коде используется On Error Resume Next
Да используется, так как вы и написали ранее этот код, возможно его можно сократить, но я в нем координально ничего не менял.
Код
Attribute VB_Name = "Module4"
Sub EXP() 'Макрос сохранения листа в новую книгу и отправки через Outlook
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
.sToSavePath = Application.GetSaveAsFilename(InitialFileName:=sAttachment, fileFilter:="Excel book(*.xlsx), *.xlsx")
.SaveAs sAttachment, xlOpenXMLWorkbook
.Close False
End With
Application.DisplayAlerts = True
'создаем сообщение
With objMail
.To = Range("A3").Value 'адрес получателя
.Subject = ActiveSheet.Name 'тема сообщения
.Body = "Текст письма..."
'добавляем вложение, если файл по указанному пути существует(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
я написать не мог никак. Это уже Ваши "доработки", которые как Вам кажется работают, но это не так. Как минимум, это не может работать так, как должно.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Благодарю за помощь. крутил вертел я тот макрос, ничего не получалось. То выбираешь файл куда сохранить, а сохраняет всеравно не туда. Сделал, сохраняет куда покажешь, но тогда в письмо его не прикрепляет. вообщем провозился зря, надо изучать всё полностью с азов.
Но наконец-то додел я макрос, именно тот который был у меня изначально Он короче в два раза! и намного проще чем все ранее предложенные портянки с сохранением листа в отдельну книгу, причем всё гораздо легче, сохранить лист в отдельную книгу можно и без переменных, а также не нужна проверка открыт ли уже Outlook или нет, если нет, он запустится. В итоге всё работает, сохраняет как надо, куда надо и с нужным именем. Письмо создает, файл прикрепляет. Кому необоходимо пользуйтесь.
Код
Sub Save_and_Mail()
With Application.FileDialog(msoFileDialogSaveAs)
.InitialFileName = ActiveWorkbook.Path & "\" & ActiveWorkbook.ActiveSheet.Name
If .Show = 0 Then Exit Sub
ActiveWorkbook.ActiveSheet.Copy
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=.SelectedItems(1)
Application.DisplayAlerts = True
End With
Dim OutlookApp As Object, SM As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set SM = OutlookApp.CreateItem(olMailItem)
'SM.SentOnBehalfOfName = "mail@example.ru" 'Поле "От", если нужен другой отправитель
SM.To = Range("A3").Value 'адрес получателя
SM.Subject = ActiveSheet.Name 'тема сообщения
On Error Resume Next
SM.Body = "Текст Письма planetaexcel"
SM.Attachments.Add ActiveWorkbook.Path & "\" & ActiveWorkbook.Name 'Адрес вложения
SM.Display
Set SM = Nothing
Set OutlookApp = Nothing
End Sub
Здравствуйте. Собственно сабж, но точная причина в том, что имя файла содержит точку. Часть кода:
Код
FName = "Бронь. Колбаса"
FName = Application.GetSaveAsFilename(InitialFileName:=FName, _
FileFilter:="Excel Files (*.xlsx), *.xlsx", _
Title:="Выберите или введите имя файла для сохранения")
If VarType(FName) <> vbBoolean Then ActiveWorkbook.SaveAs FName
Если между "Бронь" и "Колбаса" стоит точка, то имя файлы по умолчанию в диалоговом окне не подставляется. Без точки - подставляется. Т.е. именно точка блокирует эту возможность. Есть решение? Надо чтобы точка была, но не мешала.
То что в какой то момент , разрешили использовать точку в имени не как разделитель, не означает что это правильно. Не проверял, но предположу что заданный фильтр *.xlsx блокирует , считая то что после точки расширением не попадающим под него.