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

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