VBA-将单元格附加到电子邮件正文中的麻烦（Outlook）
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/1488616/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
VBA-Trouble with attaching cells into body of email(Outlook)
提问by Anna
I am using excel 2003 and I am having trouble attaching cells onto the body of an email. I got some of the code off http://www.rondebruin.nl/mail/folder3/mail4.htmbut it does not work for me. What happens to me is that a spreadsheet would pop up that has Not Peer Review on it and an error message saying "runtime error '1004' PasteSpecial method of Range class failed". Please provide assistance.
我正在使用 excel 2003，但在将单元格附加到电子邮件正文时遇到问题。我从http://www.rondebruin.nl/mail/folder3/mail4.htm 获取了一些代码，但它对我不起作用。发生在我身上的是，会弹出一个电子表格，上面没有同行评审，并显示一条错误消息，指出“Range 类的运行时错误‘1004’ PasteSpecial 方法失败”。请提供帮助。
Below is the code (the code in bold is the error):
下面是代码（粗体代码是错误）：
'' 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 = "[email protected]"
'' 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
回答by Atmocreations
Replace the erronous line
更换错线
.Cells(1).PasteSpecial Paste:=8
with
和
.Cells(1).PasteSpecial xlPasteColumnWidths, xlPasteSpecialOperationNone, False, False
Another possibility would be to write your own code generating the html, it's quite easy:
另一种可能性是编写自己的代码来生成 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
Sure, the format isn't copied this way. You would have to add it yourself though. And the rest of your email-message needs to be constructed as well.
当然，格式不是这样复制的。不过，您必须自己添加它。您的电子邮件的其余部分也需要构建。
hope that helps a bit out
希望有所帮助
regards
问候
回答by Fionnuala
How about:
怎么样：
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>", " ")
s = s & "</td></tr></table>"
RangetoHTML = s
rs.Close
cn.Close
Set rs = Nothing
Set cn = Nothing
End Function
