Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос для отправки листа через Outlook
 
#1
07.11.2019 08:13:35
Привет всем.

Прошу помочь продолжить макрос со следующим требованием

У меня есть макрос который сохроняет текущий лист со значениями в новый эксел с название указанного в определенном ячейке.

Теперь я хочу отправить этот эксел через 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]

End Sub
Изменено: ramin911 - 07.11.2019 08:15:12
 
 
 
#2
07.11.2019 08:16:32
Вот тут все уже дополнено. Изучайте. И оформите код правильно, а то красный цвет глаза режет   8)
Изменено: Nordheim - 07.11.2019 08:18:39
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#3
07.11.2019 09:57:19
Нашел это. Так как я не хорошо разбираюсь в макросе, если не трудно подскажите как объединить с этим кодом


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
 
 
 
#4
07.11.2019 11:11:22
Код
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
Изменено: МатросНаЗебре - 07.11.2019 11:19:11
 
 
 
Страницы: 1
Наверх