Option Explicit
Sub Selection_email()
Dim bStarted As Boolean
Dim olApp As Object
Dim oItem As Outlook.MailItem
Dim olMailItm As Object
Dim rngTo As Range
Dim rngSubject As Range
Dim Last As Variant
Dim htmlString As String
Dim beginBody, endBody As String
Dim oOutlookApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Set olMailItm = olApp.CreateItem(0)
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oItem = oOutlookApp.CreateItem(olMailItem)
With ActiveSheet
Set rngTo = .Range("E3")
Last = ActiveSheet.Cells(2, 4).Value
End With
'create the HTML table first --
' this builds a string with proper HTML header info
htmlString = RangetoHTML(ActiveSheet.Range("A1:D6"))
'now add the email greeting to the body information
beginBody = Left(htmlString, InStr(1, htmlString, "<body>", vbTextCompare) + 6)
endBody = Right(htmlString, Len(htmlString) - InStr(1, htmlString, "<body>", vbTextCompare) + 5)
htmlString = beginBody & _
"Hello,<br><br>Welcome to My World<br><br>" & _
endBody
'now find the end of the table and add the signoff message
beginBody = Left(htmlString, InStr(1, htmlString, "</div>", vbTextCompare) + 6)
endBody = Right(htmlString, Len(htmlString) - InStr(1, htmlString, "</div>", vbTextCompare) + 5)
htmlString = beginBody & _
"<br><br>Thank you for your cooperation." & _
endBody
With oItem
.SentOnBehalfOfName = ""
.To = rngTo.Value
.CC = ""
.Subject = "" & Last & ""
.HTMLBody = htmlString
.Display
End With
If bStarted Then
oOutlookApp.Quit
End If
Set oOutlookApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
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
