Hi,
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.htm but 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.
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