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

提示:将鼠标放在中文语句上可以显示对应的英文。显示中英文
时间:2020-09-11 10:50:33  来源:igfitidea点击:

VBA-Trouble with attaching cells into body of email(Outlook)

excelvbaexcel-vbaoutlook-vba

提问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>", "&nbsp;")
s = s & "</td></tr></table>"

RangetoHTML = s

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