VBA-Проблема с подключением ячеек к телу электронной почты (Outlook)

Question

Я использую Excel 2003, и у меня возникают проблемы с прикреплением ячеек к телу письма. Я получил часть кода с http://www.rondebruin.nl/mail/folder3/mail4.htm но он не работает для меня. Что происходит со мной, так это то, что может появиться электронная таблица, в которой есть "Не экспертная проверка", и сообщение об ошибке "Ошибка во время выполнения" 1004 "Сбой в методе PasteSpecial класса Range". Пожалуйста, предоставьте помощь.

Ниже приведен код (код, выделенный жирным шрифтом, является ошибкой):

'' Creates Email  

Sub Email_Click()  
Dim sDate As Date  
sDate = ThisWorkbook.Sheets("SheetA").Range("H4").Value  

Dim olApp As Outlook.Application  
Dim olMail As MailItem  
Dim tmp  
Set olApp = New Outlook.Application  

'' Location of email template  
Set olMail = olApp.CreateItem(olMailItem)  
ThisWorkbook.Worksheets("SheetB").Activate  
Application.ActiveSheet.Columns("A:E").AutoFit  

Dim totalRows As Integer
totalRows = Application.ActiveSheet.UsedRange.Rows.count  

With olMail  
'' Subject  
.Subject = "Email"   
.BodyFormat = olFormatHTML  
.To = "[e-mail]"  

'' Body  
.HTMLBody = RangetoHTML(Application.ActiveSheet.Range("A1:E" & totalRows))   
.Display  

End With  
Set olMail = Nothing  
Set olApp = Nothing  
ThisWorkbook.Worksheets("Base Sheet").Activate  

End Sub 

Function RangetoHTML(rng As Range)  
'' Changed by Ron de Bruin 28-Oct-2006  
'' Working in Office 2000-2007  
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"  

''Copy the range and create a new workbook to past the data in  
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  
.DrawingObjects.Visible = True  
.DrawingObjects.Delete  
On Error GoTo 0  
End With    

''Publish the sheet to a htm file  
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  

''Read all data from the htm file into RangetoHTML  
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=")  

''Close TempWB  
TempWB.Close savechanges:=False  
''Delete the htm file we used in this function  
Kill TempFile  
Set ts = Nothing  
Set fso = Nothing  
Set TempWB = Nothing  

End Function

Answer 1

Заменить ошибочную строку

.Cells(1).PasteSpecial Paste:=8

с

.Cells(1).PasteSpecial xlPasteColumnWidths, xlPasteSpecialOperationNone, False, False

---

Другой возможностью было бы написать собственный код, генерирующий HTML, это довольно просто:

Public Sub 
    Dim crtRow as Integer
    Dim crtCol as Integer

    Dim tempBody as String
    tempBody = "<table>" & vbNewline
    For crtRow = 0 To maxRow
        tempBody = tempBody & "  <tr>" & vbNewline
        For crtCol = 0 To maxCol
            tempBody = tempBody & "  <td>" & yourWorksheet.Cells(maxRow, maxCol).Value & "</td>" &  vbNewline
        Next crtCol
        tempBody = tempBody & "  </tr>" & vbNewline
    Next crtRow
    tempBody = "</table>" & vbNewline

    yourEmail.HTMLBody = tempBody
End Sub

Конечно, формат не копируется таким образом. Вы должны были бы добавить это все же. И остальная часть вашего электронного сообщения также должна быть составлена.

надеюсь, что это поможет немного

С уважением

Answer 2

Как насчет:

s = RangetoHTML(Application.ActiveSheet.Name & "$" & "A1:E" & totalRows)

Function RangetoHTML(rng As String)
''Reference: Microsoft ActiveX Data Objects x.x Library
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset

strFile = Workbooks(1).FullName
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _
    & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"

cn.Open strCon

rs.Open "SELECT * FROM [" & rng & "]", cn

s = "<table border=""1"" width=""100%""><tr><td>"

s = s & rs.GetString(, , "</td><td>", "</td></tr><tr><td>", "&nbsp;")
s = s & "</td></tr></table>"

RangetoHTML = s

rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
End Function