CODEWITHSUNDEEP
excelvbaoutlook
Anna
Anna

Reputation: 1

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

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

Upvotes: 0

Views: 10769

Answers (2)

Fionnuala
Fionnuala

Reputation: 91356

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

Upvotes: 0

Atmocreations
Atmocreations

Reputation: 10061

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:

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

Upvotes: 1

Related Questions