首页 文章

VBA-将单元格附加到电子邮件正文中的麻烦（Outlook）

提问于
浏览 次
0

我正在使用excel 2003，我无法将单元格附加到电子邮件的正文中 . 我从http://www.rondebruin.nl/mail/folder3/mail4.htm获得了一些代码，但它对我不起作用 . 我发生的情况是会弹出一个电子表格，其中包含Not Peer Review，并显示错误消息"runtime error '1004' PasteSpecial method of Range class failed" . 请提供帮助 .

下面是代码（粗体代码是错误）：

'' 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 = "emailsheet@gmail.com"  

'' 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
excel vba excel-vba outlook-vba

2 回答

  • 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

    当然，格式不会以这种方式复制 . 你必须自己添加它 . 还需要构建其余的电子邮件消息 .

    希望有所帮助

    问候

    回复于
  • 0

    怎么样：

    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
    回复于

相关问题