Прошу помочь продолжить макрос со следующим требованием
У меня есть макрос который сохроняет текущий лист со значениями в новый эксел с название указанного в определенном ячейке.
Теперь я хочу отправить этот эксел через outlook на почту указанную в определенном ячейке
Вот мой текущий макрос
Sub SaveSheet() Dim ActiveSht As Worksheet Dim NewWb As Workbook Set ActiveSht = ActiveSheet Set NewWb = Workbooks.Add ActiveSht.Copy Before:=Workbooks(NewWb.Name).Sheets(1) With ActiveSheet.UsedRange .Value = .Value End With ActiveWorkbook.SaveAs Filename:="N:\Accounting\Payroll\National\OVERTIME REPORT\2019\" & [A16]
Нашел это. Так как я не хорошо разбираюсь в макросе, если не трудно подскажите как объединить с этим кодом
Sub Send_Mail() Dim objOutlookApp As Object, objMail As Object Dim sTo As String, sSubject As String, sBody As String, 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 objOutlookApp.Session.Logon Set objMail = objOutlookApp.CreateItem(0) 'создаем новое сообщение 'если не получилось создать приложение или экземпляр сообщения - выходим If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
sTo = "AddressTo@mail.ru" 'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value) sSubject = "Автоотправка" 'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value) sBody = "Привет от Excel-VBA" 'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value) sAttachment = "C:\Temp\Книга1.xls" 'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
'создаем сообщение With objMail .To = sTo 'адрес получателя .CC = "" 'адрес для копии .BCC = "" 'адрес для скрытой копии .Subject = sSubject 'тема сообщения .Body = sBody 'текст сообщения '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.) .Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра End With
Set objOutlookApp = Nothing: Set objMail = Nothing Application.ScreenUpdating = True End Sub
Sub SaveSheet()
Dim ActiveSht As Worksheet
Dim NewWb As Workbook
Set ActiveSht = ActiveSheet
Set NewWb = Workbooks.Add
ActiveSht.Copy Before:=Workbooks(NewWb.Name).Sheets(1)
With ActiveSheet.UsedRange
.Value = .Value
End With
Dim sFull As String
Dim sMail As String
sFull = "N:\Accounting\Payroll\National\OVERTIME REPORT\2019\" & [A16]
sMail = [A1]
ActiveWorkbook.SaveAs Filename:=sFull
SendEmailUsingOutlook True, "Лови.", sMail, , , "На те файлик", sFull
End Sub
Function SendEmailUsingOutlook(ByRef SendMode As Variant, _
ByVal MailText$, _
ByVal Email$, _
Optional ByVal CopyTo$, _
Optional oOutlook As Object, _
Optional ByVal Subject$ = "", _
Optional ByVal AttachFilename As Variant, _
Optional ByVal from As String) _
As Boolean
' функция производит отправку письма с заданной темой и текстом на адрес Email
' с почтового ящика, настроенного в Outlook для отправки писем "по-умолчанию"
' Если задан параметр AttachFilename, к отправляемому письму прикрепляется файл (файлы) On Error Resume Next: Err.Clear
If oOutlook Is Nothing Then Set oOutlook = GetObject(, "Outlook.Application")
If oOutlook Is Nothing Then
Set oOutlook = CreateObject("Outlook.Application")
Dim olNs As Object: Set olNs = oOutlook.GetNamespace("MAPI")
Dim mailFolder As Object: Set mailFolder = olNs.GetDefaultFolder(6)
End If
If oOutlook Is Nothing Then MsgBox "Не удалось запустить OUTLOOK для отправки почты", vbCritical: Exit Function
Err.Clear
With oOutlook.CreateItem(0) 'создаем новое сообщение
.To = Email$: .Subject = Subject$: .Body = MailText$
If from <> "" Then _
.SentOnBehalfOfName = from
.CC = CopyTo$
If VarType(AttachFilename) = vbString Then .Attachments.Add AttachFilename
If VarType(AttachFilename) = vbObject Then ' AttachFilename as Collection
Dim file As Object
For Each file In AttachFilename: .Attachments.Add file: Next
End If
Err.Clear
Select Case SendMode
Case True: .Send
Case False: .Save
Case "Display": .Display
End Select
SendEmailUsingOutlook = Err = 0
End With
End Function