Sub Send_Mail()
Dim oOutlApp As Object, objMail As Object
Dim sTo As String, sSubject As String, sBody As String, sTblBody As String, sAttachment As String
Dim rDataR As Range
Dim IsOultOpen As Boolean
Application.ScreenUpdating = False
'Пробуем подключиться к Outlook
On Error Resume Next
Set oOutlApp = GetObject(, "Outlook.Application")
If Err = 0 Then
IsOultOpen = True
Else
Err.Clear
Set oOutlApp = CreateObject("Outlook.Application")
End If
oOutlApp.Session.Logon
Set objMail = oOutlApp.CreateItem(0) 'создаем новое сообщение
'если не получилось создать приложение или экземпляр сообщения - выходим
If Err.Number <> 0 Then Set oOutlApp = Nothing: Set objMail = Nothing: Exit Sub
With ActiveSheet
sTo = .Range("B2").Value
sSubject = .Range("B3").Value
sBody = .Range("B4").Value
sAttachment = .Range("").Value
'Переносы строк и шрифт
sBody = Replace(sBody, Chr(10), "<br />")
sBody = Replace(sBody, vbNewLine, "<br />")
sBody = "<span style=""font-size: 14px; font-family: Arial"">" & sBody & "</span>"
'Таблица
'важно добавлять таблицу после оформления переносов строк и шрифта
'в противном случае форматирование таблицы может "поплыть"
Set rDataR = .Range("") 'Selection - если надо отправить только выделенные диапазона
sTblBody = ConvertRngToHTM(rDataR)
'подменяем метку {TABLE} в тексте письма реальной таблицей(сформированной выше)
sBody = Replace(sBody, "{TABLE}", sTblBody)
End With
'создаем сообщение
With objMail
.To = sTo 'адрес получателя
' .CC = "" 'адрес для копии
' .BCC = "" 'адрес для скрытой копии
.Subject = sSubject 'тема сообщения
.BodyFormat = 2 'olFormatHTML - формат HTML
' .Body = RangeToTextTable(Selection) 'вставляем таблицу без форматирования
.HTMLBody = sBody
If sAttachment <> "" Then
.Attachments.Add sAttachment
End If
.display 'если необходимо просмотреть сообщение, а не отправлять без просмотра
'.Send 'если необходимо отправить сообщение без просмотра
End With
If IsOultOpen = False Then oOutlApp.Quit
Set oOutlApp = Nothing: Set objMail = Nothing
DoEvents
End Sub
Function ConvertRngToHTM(rng As Range)
Dim fso As Object, ts As Object
Dim sF As String, resHTM As String
Dim wbTmp As Workbook
sF = Environ("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'переносим указанный диапазон в новую книгу
rng.Copy
Set wbTmp = Workbooks.Add(1)
With wbTmp.Sheets(1)
'вставляем только ширину столбцов, значения и форматы
.Cells(1).PasteSpecial xlPasteColumnWidths
.Cells(1).PasteSpecial xlPasteValues
.Cells(1).PasteSpecial xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
'удаляем все объекты(фигуры, рисунки и пр.)
'------------------------------------------
'если рисунки и объекты нужны - удалить этот блок
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
'------------------------------------------
End With
'выставляем русскую кодировку (если кириллицы в тексте нет - можно убрать)
wbTmp.WebOptions.Encoding = msoEncodingCyrillic
'сохраняем книгу как Веб-страницу(чтобы содержимое конвертировать в HTML-код)
With wbTmp.PublishObjects.Add( _
SourceType:=xlSourceRange, Filename:=sF, _
Sheet:=wbTmp.Sheets(1).Name, Source:=wbTmp.Sheets(1).UsedRange.Address(1, 1, Application.ReferenceStyle), _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'открываем созданный файл как текстовый и считываем содержимое
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sF).OpenAsTextStream(1, -2)
resHTM = ts.ReadAll
ts.Close
'выравниваем таблицу по левому краю(если надо оставить по центру - удалить эту строку)
ConvertRngToHTM = Replace(resHTM, "align=center x:publishsource=", "align=left x:publishsource=")
'закрываем временную книгу и удаляем
wbTmp.Close False
Kill sF
'очищаем объектные переменные
Set ts = Nothing: Set fso = Nothing
Set wbTmp = Nothing
End Function
Function RangeToTextTable(rng As Range)
Dim lr As Long, lc As Long, arr
Dim res As String, rh()
Dim lSpaces As Long, s As String
arr = rng.Value
If Not IsArray(arr) Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = rng.Value
End If
ReDim rh(1 To UBound(arr, 2))
For lr = 1 To UBound(arr, 1)
For lc = 1 To UBound(arr, 2)
If Len(arr(lr, lc)) > rh(lc) Then
rh(lc) = Len(arr(lr, lc))
End If
Next
Next
For lr = 1 To UBound(arr, 1)
For lc = 1 To UBound(arr, 2)
s = arr(lr, lc)
lSpaces = rh(lc) - Len(s)
If lSpaces > 0 Then
s = s & Space(lSpaces)
End If
If lc = 1 Then
res = res & s
Else
res = res & vbTab & s
End If
Next
res = res & vbNewLine
Next
RangeToTextTable = res
End Function
|