Wrong row height when copying a range from Excel into outlook with VBA

[lejosh]

Hello


I have this macro below that I made from various sources (including here).
It generates an outlook email from a range in excel.

It successfully works, but there's one last detail i'm trying to figure out.

When I simply create a new email and copy/paste my excel range manually in the body of the email, the row heights are the same as in the original excel file.
But when I use the macro instead, the row height in the email is too big (0.53cm instead of approx 0.3cm).

So the time I save copy/pasting my stuff manually, I loose resizing the rows.

Does anyone know how to solve this?


Using Excel & Outlook 2007 on Windows Vista pro

Many thanks!

Sub preparemail()


Dim OutApp As Object
Dim OutMail As Object

Dim Ash As Worksheet
Set Ash = ActiveSheet

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon


Set OutMail = OutApp.CreateItem(0)

With OutMail
.To = "me@me.com"
.Subject = "test"
.HTMLBody = RangetoHTML(Sheets("Overview").Range("A2:H15")) 
.Display 
End With


cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub







'''''''''''''''''
Function RangetoHTML(rng As Range)

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

 

[AlphaFrog]

The problem is in the RangetoHTML function. It doesn't copy the row heights or column widths.

Add the code in red below to Function RangetoHTML to get the row heights.

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    [COLOR="Red"]Dim r As Long[/COLOR]
 
    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
        
[COLOR="Red"]        For r = 1 To rng.Rows.Count
            .Rows(r).RowHeight = rng.Rows(r).RowHeight
        Next r[/COLOR]
        
    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

 

[lejosh]

Thanks it works!

 

[Kentetsu]

AlphaFrog,

I'm having the same issue (row heights are huge after VBA pasting to email body) but your solution seems to be having no effect. The spreadsheet formatting is fine, but the email is not. Any thoughts?

Option Explicit

Sub MailMe()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    With Sheets("PII Yields")
        .Visible = True
        .Activate
    End With

Set rng = Nothing
'Set rng = ActiveSheet.UsedRange
Set rng = Selection
    'You can also use a sheet name
    'Set rng = Sheets("YourSheet").UsedRange

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next

    With OutMail
        .To = "Smith, Mark"
        .CC = ""
        .BCC = ""
        .Subject = "Recap"
        .HTMLBody = RangetoHTML(rng)
'        .Send   'or use .Display
        .Display
    End With
    
On Error GoTo 0

    With Application
        .EnableEvents = True
    End With

Set OutMail = Nothing
Set OutApp = Nothing
    
End Sub

'----------------------------------------------------------------------------------------------------------------

Function RangetoHTML(rng As Range)

Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim r As Long
Application.ScreenUpdating = False

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
'        .Cells(1).PasteSpecial Paste:=8
'        .Cells(1).PasteSpecial xlPasteValues, , False, False
                .Cells(1).PasteSpecial xlPasteColumnWidths
'                .Cells(1).PasteSpecial xlPasteRowHeight
'        .Cells(1).PasteSpecial xlPasteFormats, , False, False
'        .Cells(1).Select

For r = 1 To rng.Rows.Count
            .Rows(r).RowHeight = rng.Rows(r).RowHeight
        Next r



        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
    
'    Sheets("PII Yields").Visible = xlSheetVeryHidden

End Function

Thanks...

 

[AlphaFrog]

Does the email table have a large font size (fills the cells) as well, or is the table's font smaller with a tall row height?

What's the row height and font size on the worksheet?

 

[Kentetsu]

AlphaFrog,

The font size is the standard for the table (11) in both the tables and the email. Everything fits fine in the spreadsheet, but for some reason (possibly due to wrap text function?) in the email the columns are very tall and the text does not fill the cell.

I've uploaded a copy of the spreadsheet that is built (contains no VBA, just a few tables) if it would help to view it: https://www.dropbox.com/s/87gp0xovh0nfj1x/Recap.xlsm?dl=0

I wish I could post a screenshot of the email results, but not sure if that's possible. I could forward it to you if you like though.

Thank you for taking the time to assist...

 

[AlphaFrog]

Un-Comment this

' rng.Copy

Otherwise you're just pasting the last thing copied to the clipboard

 

[Kentetsu]

Um, yeah. I had to comment that out because with it there I end up with a blank email (well, a single rectangular box of color about the size of one cell). I just tried it again, with the same results.

I'm performing that function right before I call the MailMe sub:

Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 10)
End With
        
rng.Copy

Call MailMe

Is that a problem?

 

[AlphaFrog]

MailMe works from the current selection (unless you change the code). So this code should select the range before calling MailMe.

Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp)).Resize(, 10)
End With
        
rng.[U]Select[/U]

Call MailMe

Then the function RangetoHTML copies the range passed to its' argument rng, but you commented the copy command

Un-comment rng.Copy in the RangetoHTML function.

The rng variable is not shared between the procedures unless you pass the variable as MailMe does with RangetoHTM.

 

[Kentetsu]

You are the Man, er, Frog!

That did the trick Sir. Thanks again for the education..

P.S. Funny that even as screwed up as I had it, it still did 99% of what I wanted. If it weren't for that row height issue I'd've never known there was a problem.