doingsomething

Excel VBA convert a named ranged to HTML and send email

Mar 30th, 2015
1,495
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 2.63 KB | None | 0 0
  1. Sub send_html_formatted_email()
  2. 'This is code I found and modified to my needs, I take no credit
  3. 'Sends email with body formatted to HTML
  4. 'This sub calls Function RangetoHTML (see below) to convert a named range to HTML
  5.  
  6. Dim OutApp As Object
  7. Dim OutMail As Object
  8. Dim rng As Range
  9.  
  10. Set rng = [some_named_range]
  11.  
  12. If rng Is Nothing Then
  13. MsgBox "Try again"
  14. Exit Sub
  15. End If
  16.  
  17. Set OutApp = CreateObject("Outlook.Application")
  18. Set OutMail = OutApp.CreateItem(0)
  19.  
  20. With OutMail
  21. .To = "name@email.com"
  22. .CC = "name@email.com"
  23. .BCC = "name@email.com"
  24. .Subject = "Dashboard for " & Now()
  25. .HTMLBody = RangetoHTML(rng)
  26. '.Body = strbody
  27. '.Send 'or use .Display
  28. .Send
  29. End With
  30.  
  31. Set OutMail = Nothing
  32. Set OutApp = Nothing
  33.  
  34. End Sub
  35.  
  36. '--------------------------------------------------------------------------------------
  37. Function RangetoHTML(rng As Range)
  38. ' Changed by Ron de Bruin 28-Oct-2006
  39. ' Working in Office 2000-2010
  40.  
  41. Dim fso As Object
  42. Dim ts As Object
  43. Dim TempFile As String
  44. Dim TempWB As Workbook
  45.  
  46. TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
  47.  
  48. 'Copy the range and create a new workbook to past the data in
  49. rng.Copy
  50. Set TempWB = Workbooks.Add(1)
  51. With TempWB.Sheets(1)
  52. .Cells(1).PasteSpecial Paste:=8
  53. .Cells(1).PasteSpecial xlPasteValues, , False, False
  54. .Cells(1).PasteSpecial xlPasteFormats, , False, False
  55. .Cells(1).Select
  56. Application.CutCopyMode = False
  57. On Error Resume Next
  58. .DrawingObjects.Visible = True
  59. .DrawingObjects.Delete
  60. On Error GoTo 0
  61. End With
  62.  
  63. 'Publish the sheet to a htm file
  64. With TempWB.PublishObjects.Add( _
  65. SourceType:=xlSourceRange, _
  66. Filename:=TempFile, _
  67. Sheet:=TempWB.Sheets(1).Name, _
  68. Source:=TempWB.Sheets(1).UsedRange.Address, _
  69. HtmlType:=xlHtmlStatic)
  70. .Publish (True)
  71. End With
  72.  
  73. 'Read all data from the htm file into RangetoHTML
  74. Set fso = CreateObject("Scripting.FileSystemObject")
  75. Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
  76. RangetoHTML = ts.ReadAll
  77. ts.Close
  78. RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
  79. "align=left x:publishsource=")
  80.  
  81. 'Close TempWB
  82. TempWB.Close savechanges:=False
  83.  
  84. 'Delete the htm file we used in this function
  85. Kill TempFile
  86.  
  87. Set ts = Nothing
  88. Set fso = Nothing
  89. Set TempWB = Nothing
  90. End Function
Add Comment
Please, Sign In to add comment