title: export table to outlook from excel that is blackberry friendly
body: <p>So I gathered from different places on the internet some code to export a table into outlook and send it out automatically and have just noticed that the email is not really blackberry friendly (mainly due to the fact that the email body is sent as HTML and not as "Rich Text", REMEMBER the table needs to also be in rich format). I am missing a line of code that will tell outlook to send email as "Rich Text" but I do not know what it is. Can anyone help me? Please see full code attached below (apologies for the lenght of the code in advance).</p>
  
  <p>Thanks
  P</p>
  
  <p><code></p>
  
  <pre>Sub Mail_Sheet_Outlook_Body()
      Dim rng As Range
      Dim OutApp As Object
      Dim OutMail As Object
      With Application
          .EnableEvents = False
          .ScreenUpdating = False
      End With
  
      Set rng = Nothing
      Set rng = Selection.SpecialCells(xlCellTypeVisible)
  
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
  
      On Error Resume Next
      With OutMail
          .To = "email@email.com"
          .CC = ""
          .BCC = ""
          .Subject = "Enter Subject text here"
          .HTMLBody = RangetoHTML(rng)
         '.Attachments.Add ("c:\temp\" &amp; ActiveSheet.Range("DateSerial").Value &amp; ".pdf")
          .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)
  ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
      Dim fso As Object
      Dim ts As Object
      Dim TempFile As String
      Dim TempWB As Workbook
  
      TempFile = Environ$("temp") &amp; "/" &amp; Format(Now, "dd-mm-yy h-mm-ss") &amp; ".htm"
  
      ' Copy the range and create a workbook to receive the data.
      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 an .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 the RangetoHTML subroutine.
      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.
      Kill TempFile
  
      Set ts = Nothing
      Set fso = Nothing
      Set TempWB = Nothing
  End Function
  </code></pre>