Не помогло. Если вставить таблицу в файл Дмитрия - работает, а если скопировать его код к себе - нет.
Текст макроса привожу ниже:
Код |
---|
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
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 = Range("AF4") 'Тема письма(можно заменить значением из ячейки - sSubject = Range("A2").Value)
sBody = "Странно, что не отображается " & Range("B9") & "\Microsoft\Signatures\"
Dim sTblBody As String
sTblBody = ConvertRngToHTM(Selection)
'Текст письма(можно заменить значением из ячейки - 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, если необходимо просмотреть сообщение, а не отправлять без просмотра
.Display
End With
Set objOutlookApp = Nothing: Set objMail = Nothing
Application.ScreenUpdating = True
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
'сохраняем книгу как Веб-страницу(чтобы содержимое конвертировать в HTML-код)
With wbTmp.PublishObjects.Add( _
SourceType:=xlSourceRange, Filename:=sF, _
Sheet:=wbTmp.Sheets(1).Name, Source:=wbTmp.Sheets(1).UsedRange.Address, _
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
|