views:

1155

answers:

2

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
+1  A: 

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

Atmocreations
When I tried the first method, excel gives me a compile error: syntax error. And I am not sure how to incorporate the second method into the codes.
Anna
well the reason for this is that I wrote it wrong. Now it's correct, the "Paste:=8" for sure needs to be _removed_. sorry and regards
Atmocreations
i tried the new code but i still get the error message "runtime error '1004' PasteSpecial method of Range class failed" with the new code highlighted.
Anna
add a breakpoint on the failing line and execute. When execution stops, type into your direct window: `print vartype(TempWB.Sheets(1))` and dump the result here. also find whether the object is null by typing `print (TempWB.Sheets(1) Is Nothing)` and dump the output.
Atmocreations
do i add "print vartype(TempWB.Sheets(1))" infront of the breakpoint code?
Anna
when i add "print vartype(TempWB.Sheets(1))" infront of the breakpoint, a error comes out saying "Compile error: method not valid without suitable object"
Anna
when i add "print (TempWB.Sheets(1) Is Nothing)" infront of the breakpoint, the same error shows up.
Anna
yes. There are two possibilities. Either you write `Debug.Print` (instead of Print) right in front of the breakpoint-line (if so, you wouldn't need to set a breakpoint), OR you let the execution break at that point and then you write it in the Debug-Window. You should be able to access this by the menu View > Direct. You can then type it and press Enter to confirm. You should get the response on the line below.
Atmocreations
For "print vartype(TempWB.Sheets(1))", I get the result "9".For "print (TempWB.Sheets(1) Is Nothing)", I get the result "False".
Anna
try removing the With-Block and put the fully qualified name each time. Sometimes this solves strange problems in VBA... and you might want to try `If TypeOf TempWB.Sheets(1) Is Worksheet Then` and `Debug.Print "Is really a worksheet"` followed by `End If` right in front of the breakpoint-line.
Atmocreations
I did the full name but it still has the error. And when I added the If code in, it does not return anything. I wonder if my function, RangetoHTML(rng As Range), really has a rng value. How can I check that?
Anna
you can check this by putting something like `If TypeOf rng Is Range Then ...` and you gotta put some code. You again may put a breakpoint and write this in the direct-window, with a "Print" in front of it.
Atmocreations
one more remark: if you create a new workbook by the New-button, as default you get three sheets. But is this true if you create it through VBA? Maybe not. You might have to create a Worksheet. I guess this would be something like `Dim myWS as Worksheet` and `Set myWS = TempWB.Sheets.Add(...)`
Atmocreations
I already hav a workbook created except i cant paste the range values to the new workbook.
Anna
A workbook is a xls-file. A workbook can contain one or multiple worksheets. The thing you paste and write on is a workSHEET. Therefore you need worksheets. In Excel you see worksheets as tabs at the bottom edge. A newly created workbook contains the worksheets Sheet1, Sheet2 and Sheet3. Please verify that TempWB.Sheets.Count > 0, otherwise it won't work. I don't see any other error source...
Atmocreations
TempWB.Sheets.Count > 0 is True.I asked someone and they told me that it's because of the "Not Peer Review" on the new spreadsheet that pops out. Would you know a way to fix that?
Anna
A: 

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
Remou