Option Explicit 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 'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть) ' [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии] 'objOutlookApp.Session.Logon "profile","1234",False, True 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 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.) 'добавляем вложение, если файл по указанному пути существует(dir проверяет это) If sAttachment <> "" Then If Dir(sAttachment, 16) <> "" Then .Attachments.Add sAttachment 'просто вложение 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName End If End If .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра End With Set objOutlookApp = Nothing: Set objMail = Nothing Application.ScreenUpdating = TrueEnd Sub
sAttachment = "C:\Users\Дмитрий\Desktop\Книга1.pdf"ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ sAttachment, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ False
sTo = "AddressTo@mail.ru"
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 'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть) ' [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии] 'objOutlookApp.Session.Logon "profile","1234",False, True Set objMail = objOutlookApp.CreateItem(0) 'создаем новое сообщение 'если не получилось создать приложение или экземпляр сообщения - выходим If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub sAttachment = "C:\Users\EXPRESSING\Desktop\На почту\Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY " & "г.").pdf ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ sAttachment, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ False sTo = "IbrahimBelkhoroev6@gmail.com" 'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value) sSubject = "" 'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value) sBody = "" 'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value) sAttachment = "C:\Users\EXPRESSING\Desktop\На почту\Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY " & "г.").pdf 'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value) 'создаем сообщение With objMail .To = sTo 'адрес получателя .CC = "" 'адрес для копии .BCC = "" 'адрес для скрытой копии .Subject = sSubject 'тема сообщения .Body = sBody 'текст сообщения '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.) 'добавляем вложение, если файл по указанному пути существует(dir проверяет это) If sAttachment <> "" Then If Dir(sAttachment, 16) <> "" Then .Attachments.Add sAttachment 'просто вложение 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName End If End If .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра End With Set objOutlookApp = Nothing: Set objMail = Nothing Application.ScreenUpdating = TrueEnd Sub
sAttachment = "C:\Temp\Книга1.xls" '
sAttachment = "C:\Users\EXPRESSING\Desktop\На почту\Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY г.") & ".pdf"
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 'раскомментировать строку, если в Outlook несколько учетных записей и нужно подключиться к конкретной(только если Outlook закрыть) ' [параметры]: Session.Logon "имя профиля","пароль",[показывать окно выбора профиля], [запускать в новой сессии] 'objOutlookApp.Session.Logon "profile","1234",False, True Set objMail = objOutlookApp.CreateItem(0) 'создаем новое сообщение 'если не получилось создать приложение или экземпляр сообщения - выходим If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub sAttachment = "C:\Users\EXPRESSING\Desktop\На почту\Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY г.") & ".pdf" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ sAttachment, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ False sTo = "IbrahimBelkhoroev6@gmail.com" 'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value) sSubject = "Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY г.") & ".pdf" 'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value) sBody = "" 'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value) sAttachment = "C:\Users\EXPRESSING\Desktop\На почту\Реестр грузовых авианакладных за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 11, "[$-FC22]DD.MM.YYYY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 20, "[$-FC22]DD.MM.YYYY г.") & ".pdf" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ sAttachment, Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _ False 'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value) 'создаем сообщение With objMail .To = sTo 'адрес получателя .CC = "" 'адрес для копии .BCC = "" 'адрес для скрытой копии .Subject = sSubject 'тема сообщения .body = sBody 'текст сообщения '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.) 'добавляем вложение, если файл по указанному пути существует(dir проверяет это) Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName 'добавляем подпись к письму 'создаем новое письмо Set objTmpMail = objOutlookApp.CreateItem(0) 'отображаем его - у него появится подпись objTmpMail.Display 'теперь к нашему текущему(рабочему) письму просто добавляем текст из временного objMail.body = objMail.body & objTmpMail.body 'удаляем временное письмо objTmpMail.Delete If sAttachment <> "" Then If Dir(sAttachment, 16) <> "" Then .Attachments.Add sAttachment 'просто вложение 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName End If End If .Send 'Display, если необходимо просмотреть сообщение, а не отправлять без просмотра End With Set objOutlookApp = Nothing: Set objMail = Nothing Application.ScreenUpdating = TrueEnd Sub