VBA to paste table into Outlook

D

Dani_LobP

Board Regular
Joined
Aug 16, 2019
Messages
134
Office Version
  1. 365
Platform
  1. Windows
Hi all,

I got some code that helps copy an excel table and create an email from it.
My only problem is that I can't seem to find the way or what part of the code to modify in order to keep the columns width and avoid the table going narrow.

Thanks in advance!

Below both codes I use:

VBA Code: 
Sub email1()

Dim OutApp As Object
Dim OutMail As Object
Dim count_row As Integer
Dim pop As Range
Dim str1, str2, str3, str4, EmailTo, EmailCC, EmailBCC, EmailSubject As String

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

count_row = Range("B124").End(xlDown).Row

Set pop = Sheets("MailMacro").Range("B124:O" & count_row)

str1 = Sheets("Email settings").Range("B7")
str2 = Sheets("Email settings").Range("B8")
str3 = Sheets("Email settings").Range("B10")
str4 = Sheets("Email settings").Range("B11")
EmailTo = Sheets("Email settings").Range("B3")
EmailCC = Sheets("Email settings").Range("B4")
EmailBCC = Sheets("Email settings").Range("B5")
EmailSubject = Sheets("Email settings").Range("B6")

On Error Resume Next
    With OutMail
        .SendUsingAccount = "x@x.com"
        .SentOnBehalfOfName = "x@x.com"
        .To = EmailTo
        .CC = EmailCC
        .BCC = EmailBCC
        .Subject = EmailSubject
        .Display
        .HTMLBody = str1 & "<br>" & "<br>" & str2 & "<br>" & RangetoHTML(pop) & "<br>" & str3 & "<br>" & "<br>" & str4 & "<br>" & "<br>" & .HTMLBody
        .DeferredDeliveryTime = Format(DateAdd("d", 7, VBA.Now), "dd-mmm-yyyy") & " 08:00:00 AM"
    
    End With
    On Error GoTo 0
    
Set OutMail = Nothing
Set OutApp = Nothing

End Sub

VBA Code: 
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, , True, False
        '.Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , 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 Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
I haven't tested this, but have you tried using AutoFit in the RangeToHTML sub?

VBA Code: 
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, , True, False
        '.Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        .usedRange.Columns.AutoFit ' THIS IS WHAT I ADDED
    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
 
Upvote 1
Another approach, which works for me.

Add this after the Set pop line:

VBA Code: 
    Dim style As String
    Dim rCol As Range, n As Long
    style = "<head><style>" & vbCrLf
    n = 0
    For Each rCol In pop.Columns
        n = n + 1
        style = style & "th,td:nth-child(" & n & ") {width: " & ActiveWindow.PointsToScreenPixelsX(rCol.width) & "px;}" & vbCrLf
    Next
    style = style & "</style></head>"

and change the .HTMLBody line to:
VBA Code: 
        .HTMLBody = style & str1 & "<br>" & "<br>" & str2 & "<br>" & RangetoHTML(pop) & "<br>" & str3 & "<br>" & "<br>" & str4 & "<br>" & "<br>" & .HTMLBody
 
Upvote 1
Solution
Vogateer said:
I haven't tested this, but have you tried using AutoFit in the RangeToHTML sub?

VBA Code: 
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, , True, False
        '.Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        .usedRange.Columns.AutoFit ' THIS IS WHAT I ADDED
    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
Click to expand...
Thanks mate, i added the line and tested but doesn't seem to make the change as what would be expected :/ ...
i tried making smaller the font for the items inside the table and helps, but still some columns seem to be shortened.
 
Upvote 0
John_w said:
Another approach, which works for me.

Add this after the Set pop line:

VBA Code: 
    Dim style As String
    Dim rCol As Range, n As Long
    style = "<head><style>" & vbCrLf
    n = 0
    For Each rCol In pop.Columns
        n = n + 1
        style = style & "th,td:nth-child(" & n & ") {width: " & ActiveWindow.PointsToScreenPixelsX(rCol.width) & "px;}" & vbCrLf
    Next
    style = style & "</style></head>"

and change the .HTMLBody line to:
VBA Code: 
        .HTMLBody = style & str1 & "<br>" & "<br>" & str2 & "<br>" & RangetoHTML(pop) & "<br>" & str3 & "<br>" & "<br>" & str4 & "<br>" & "<br>" & .HTMLBody
Click to expand...
Thanks mate, i added this as you recommended, but doesn't seem to work for me. Is it maybe because having too many columns? or shouldn't matter?
 
Upvote 0
Looks like i had too many columns and after removing some of them, the width and the looks apply correctly. It does seem that Outlook has a limit of how wide the mail table can be.

Thanks for the tips and help!
 
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question Question
Compose Email VBA Help
Replies
1
Views
47
Logit
Logit
earthworm
  • Question Question
Autofit table in Outlook upon copying from Excel sheet using Macro
Replies
1
Views
161
KOKOSEK
KOKOSEK
L
  • Question Question
Sending Email with Table in Body
Replies
3
Views
606
Domenic
D
P
  • Solved
What does this code do or mean
Replies
2
Views
166
Perrister
P
D
  • Question Question
VBA to Create Outlook Email Not Working for All Users
Replies
9
Views
310
Logit
Logit

Forum statistics

Threads
1,223,877
Messages
6,175,138
Members
452,614
Latest member
MRSWIN2709

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top