Добрый день
Подскажите, как доработать макрос, чтобы ниже текста вставлялась из буфера обмена таблица с данными в текст письма Outlook
Спасибо.
Подскажите, как доработать макрос, чтобы ниже текста вставлялась из буфера обмена таблица с данными в текст письма Outlook
Спасибо.
Код |
---|
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 = email 'Кому(можно заменить значением из ячейки - sTo = Range("A1").Value) sSubject = ThisWorkbook.Sheets(1).Cells(15, 1) 'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value) sBody = body1 'Текст письма(можно заменить значением из ячейки sAttachment = ThisWorkbook.Path & "\" & filename1 'Вложение(полный путь к файлу. Можно заменить значением из ячейки - sAttachment = Range("A4").Value) 'создаем сообщение With objMail .To = sTo 'адрес получателя .CC = iTM 'адрес для копии .BCC = "" 'адрес для скрытой копии .Subject = sSubject 'тема сообщения .body = ThisWorkbook.Sheets(1).Cells(18, 1) 'текст сообщения '.HTMLBody = sBody 'если необходим форматированные текст сообщения(различные шрифты, цвет шрифта и т.п.) .Attachments.Add sAttachment 'чтобы отправить активную книгу вместо sAttachment указать ActiveWorkbook.FullName .Display ' .Send ', если необходимо просмотреть сообщение, а не отправлять без просмотра End With Set objOutlookApp = Nothing: Set objMail = Nothing Application.ScreenUpdating = True End Sub |