Отправка книги или листа по электронной почте

.To = Range("A1").Value

.Cc = Range("A1").Value      'простая копия
.Bcc = Range("A1").Value    'скрытая копия

Set .SendUsingAccount = .Session.Accounts.Item("Hotmail")

Set .SendUsingAccount = .Session.Accounts.Item(Range("A15").Value)

<A HREF="C:\Документы\Бюджет.xlsx">Скачать файл</A> 

Sub Create_Mail()
Dim objOutApp As Object, objMail As Object
Set objOutApp = CreateObject("Outlook.Application")
Set objMail = objOutApp.CreateItem(0)
With objMail
   .To = "Me@mymail.ru"
   .Subject = "Hyperlink Chreck"
   .htmlbody = "<a HREF=""http://htmlbook.ru/html/a"">Скачать файл</a>"
   .display
   Set objMail = Nothing
End With
Set objOutApp = Nothing
End Sub

Dim o_Mess As Object, v_Conf As String, email As String
v_Conf = "http://schemas.microsoft.com/cdo/configuration/"
Set o_Mess = CreateObject("CDO.Message"
With o_Mess
    .To = email
    .From = "АДРЕС ПОЛУЧАТЕЛЯ"
    .Subject = "ТЕМА"
    .TextBody = "ТЕЛО СООБЩЕНИЯ"
    .AddAttachment "ПУТЬ К ФАЙЛУ КОТОРЫЙ ПРИКЛАДЫВАЕМ К ПИСЬМУ"
With .Configuration.Fields
    .Item(v_Conf & "sendusing" = 2
    .Item(v_Conf & "smtpserver" = "SMTP сервер"
    .Item(v_Conf & "smtpauthenticate" = 1
    .Item(v_Conf & "sendusername" = "АДРЕС ОТПРАВИТЕЛЯ"
    .Item(v_Conf & "sendpassword" = "ПАРОЛЬ"
    .Item(v_Conf & "smtpserverport" = 25
    .Item(v_Conf & "smtpusessl" = False
    .Item(v_Conf & "smtpconnectiontimeout" = 60
    .Update
End With
    .send
End With
Set o_Mess = Nothing

SM.to = Range("'Лист1'!g2").Value & ";  
" & Range("'Лист1'!g3").Value & "; " & Range("'Лист1'!g4").Value & "; " & Range("'Лист1'!g5").Value & "; " & Range("'Лист1'!g6").Value

Sub SendMail()
'Обязательно подключить библиотеку  Tools->References <<Microsoft CDO for Windows 2000 library>>

    Dim o_Mess As Object, v_Conf As String, email As String, i_Paht As String
    
    v_Conf = "http://schemas.microsoft.com/cdo/configuration/"
    i_Paht = ThisWorkbook.Path & "\ваша книга.xlsx" ' указываем полный путь к файлу, который хотим вложить
    email = "КОМУ@mail.ru"   'e-mail получателя
    Set o_Mess = CreateObject("CDO.Message" )   'Создаем сообщение
    With o_Mess
        .To = email   'Кому
        .From = "От Кого"   'От кого
        .Subject = "Привет"   'Тема письма
        .TextBody = "Большой привет от VBA"   'Текст письма
        If Len(i_Paht) > 0 Then .AddAttachment i_Paht   'вкладываем файл
        With .Configuration.Fields   'конфигурируем CDO
            .Item(v_Conf & "sendusing") = 2
            .Item(v_Conf & "smtpserver") = "smtp.mail.ru" 'ваш сервер SMTP:smtp.mail.ru; smtp.yandex.ru; mail.rambler.ru
            .Item(v_Conf & "smtpauthenticate") = 1
            .Item(v_Conf & "sendusername") = "ВАШ@mail.ru" 'Ваша учетная запись
            .Item(v_Conf & "sendpassword") = "пароль" 'Ваш пароль к почтовому ящику
            .Item(v_Conf & "smtpserverport") = 465 'номер порта(узнать на сайте вашей почты)
            .Item(v_Conf & "smtpusessl") = True
            .Item(v_Conf & "smtpconnectiontimeout") = 60
            .Update
        End With
        .Send 'отправляем
    End With
    Set o_Mess = Nothing
End Sub

ActiveWorkbook.ExportAsFixedFormat Type:=xlTypeXPS, Filename:= _
     "C:\Договоры\Book1.xps", Quality:=xlQualityStandard, _
     IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:= False

Sub Письмо()
    
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rng As Range
    Dim MyDate
    MyDate = Format(Date, "DD.MM.YYYY")

    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Set rng = Nothing
    Set rng = ActiveSheet.Range("AI32:CF34")


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
 
      .To = "dddd@mail.ru"
      .Subject = "Пример отправки фрагмента таблицы. Сегодня " & MyDate
        
  
        
        
        .HTMLBody = "<p style='font-family:Tahoma;font-size:12'>" & "Добрый День!" & vbCrLf & _
                    "<p style='font-family:Tahoma;font-size:12'>" & "Отчет по анкетам:" & _
                    RangetoHTML(rng) & vbCrLf & _
                    "<p style='font-family:Tahoma;font-size:12'>" & "" & vbCrLf & _
                    "<p style='font-family:Tahoma;font-size:12'>" & ""

     
        .Display
    End With
    On Error GoTo 0
    
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        On Error GoTo 0
    End With

    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    TempWB.Close savechanges:=False

    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function


 

Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
 

 Dim xRg As Range
Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
  Set xRg = Intersect(Range("E7"), Target)
    If xRg Is Nothing Then Exit Sub
    If IsNumeric(Target.Value) And Target.Value > 10 Then
        Call SendMail
    End If
End Sub  
 
Sub SendMail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
        
    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")  
    OutApp.Session.Logon
    On Error GoTo cleanup  
    Set OutMail = OutApp.CreateItem(0)   
    On Error Resume Next
   
    With OutMail
        .To = "ycui@mail.ru"
        .Subject = Range("A2").Value
        .Body = Range("E7").Value
        .Attachments.Add Range("A4").Value       
        .Send
    End With
 
    On Error GoTo 0
    Set OutMail = Nothing
 
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Option Explicit
 
Sub КаТЗ()
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
    Dim objTmpMail As Object 'временное письмо для создания подписи
    'Шаг 2: Скопируйте рабочую таблицу, вставьте ее в новую книгу и 'сохраните ее
    Sheets("Отправка КАТЗ").Copy
    ActiveWorkbook.SaveAs ThisWorkbook.Path & "\КаТЗ.xlsx"
 
    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 = ""    'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value)
    sSubject = "КаТЗ"    'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
    sBody = ""    'Текст письма(можно заменить значением из ячейки - sBody = Range("A3").Value)
    sAttachment = ""    'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value)
 
    'создаем сообщение
    With objMail
        .ReadReceiptRequested = True 'прочтение
        .OriginatorDeliveryReportRequested = True 'доставка
        .Importance = 2 'Варианты (0-normal, 1-low, 2-high)
        .To = sTo 'адрес получателя
        .CC = "" 'адрес для копии
        .BCC = "" 'адрес для скрытой копии
        .Subject = sSubject 'тема сообщения
        .Body = sBody 'текст сообщения
        .HTMLBody = sBody & .HTMLBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.)
        .Attachments.Add (ThisWorkbook.Path & "\КаТЗ.xlsx")   'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName
        .ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value ' удалить строку, если формулы нужны
        'добавляем подпись к письму
        'создаем новое письмо
        Set objTmpMail = objOutlookApp.CreateItem(0)
        'отображаем его - у него появится подпись
        objTmpMail.Display
        'теперь к нашему текущему(рабочему) письму просто добавляем текст из временного
        objMail.Body = objMail.Body & objTmpMail.Body
        objTmpMail.Delete 'удаляем временное письмо
 
        .Display 'Display/Send, если необходимо просмотреть сообщение, а не отправлять без просмотра
    End With
    ActiveWorkbook.Close SaveChanges:=True
    Kill ThisWorkbook.Path & "\КаТЗ.xlsx"
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
End Sub