VBA Excel Table to Outlook Border Issues

[elliotc]

Hi,

It appears someone else has posted a similar question regarding this but not received a solution:

http://www.mrexcel.com/forum/showthread.php?t=588628

Perhaps I can elaborate on the issue at hand.

I am using code written by Ron de Bruin in order to send a table I have created in Excel to Outlook by VBA

<!--[if gte mso 9]><xml> <w:WordDocument> <w:View>Normal</w:View> <w:Zoom>0</w:Zoom> <w:PunctuationKerning/> <w:ValidateAgainstSchemas/> <w:SaveIfXMLInvalid>false</w:SaveIfXMLInvalid> <w:IgnoreMixedContent>false</w:IgnoreMixedContent> <w:AlwaysShowPlaceholderText>false</w:AlwaysShowPlaceholderText> <w:Compatibility> <w:BreakWrappedTables/> <w:SnapToGridInCell/> <w:WrapTextWithPunct/> <w:UseAsianBreakRules/> <w:DontGrowAutofit/> </w:Compatibility> <w:BrowserLevel>MicrosoftInternetExplorer4</w:BrowserLevel> </w:WordDocument> </xml><![endif]--><!--[if gte mso 9]><xml> <w:LatentStyles DefLockedState="false" LatentStyleCount="156"> </w:LatentStyles> </xml><![endif]--><!--[if gte mso 10]> <style> /* Style Definitions */ table.MsoNormalTable {mso-style-name:"Table Normal"; mso-tstyle-rowband-size:0; mso-tstyle-colband-size:0; mso-style-noshow:yes; mso-style-parent:""; mso-padding-alt:0cm 5.4pt 0cm 5.4pt; mso-para-margin:0cm; mso-para-margin-bottom:.0001pt; mso-pagination:widow-orphan; font-size:10.0pt; font-family:"Times New Roman"; mso-ansi-language:#0400; mso-fareast-language:#0400; mso-bidi-language:#0400;} </style> <![endif]-->

  Sub Mail_Selection_Range_Outlook_Body()
  ' Don't forget to copy the function RangetoHTML in the module.
  ' Working in Office 2000-2010
      Dim rng As Range
      Dim OutApp As Object
      Dim OutMail As Object
   
      Set rng = Nothing
      On Error Resume Next
   
      Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
      On Error GoTo 0
   
      If rng Is Nothing Then
          MsgBox "The selection is not a range or the sheet is protected" & _
                 vbNewLine & "please correct and try again.", vbOKOnly
          Exit Sub
      End If
   
      With Application
          .EnableEvents = False
          .ScreenUpdating = False
      End With
   
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
   
      On Error Resume Next
      With OutMail
          .To = "ron@debruin.nl"
          .CC = ""
          .BCC = ""
          .Subject = "This is the Subject line"
          .HTMLBody = RangetoHTML(rng)
          .Send   'or use .Display
      End With
      On Error GoTo 0
   
      With Application
          .EnableEvents = True
          .ScreenUpdating = True
      End With
   
      Set OutMail = Nothing
      Set OutApp = Nothing
  End Sub
   
  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
   
      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

Unfortunately, what happens it that the exported table is copied into Outlook with all borders apart from the bottom border on the bottom row of the table.

I have run the code so that it breaks before the line:

    'Close TempWB     
TempWB.Close savechanges:=False

and it appears that there are no issues with the borders at this stage, so it must occur after the table is exported to Outlook.

If anyone can help with this, I would be very grateful. This problem is confusing me to no end.

 

[ellk123]

For anyone reading this in 2021 - I found the issue. When using the RangeToHTML function, the HTML generated makes the table rows too small to display the final border. The solution is to make your row sizes larger in Excel. Alternatively, in the RangeToHTML function add the following line:


RangetoHTML = Replace(RangetoHTML, "<tr height=19 style='height:14.4pt'>", "<tr height=21 style='height:15.6pt'>")

before the line:

'Close TempWB
TempWB.Saved = True

Where the second parameter of Replace() is your current row height, and the third parameter is a slightly larger height.