I want to copy data from a fixed range in an Excel sheet and paste on an email body.
Below is the code I have come up with. However I am not able to paste the specified range A11:H12.
Private Sub CommandButton1_Click()
On Error GoTo ErrHandler
' SET Outlook APPLICATION OBJECT.
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
' CREATE EMAIL OBJECT.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = "email"
.Subject = "test"
.Body = ActiveSheet.Range("A11:H12").Select
.Display ' DISPLAY MESSAGE.
End With
' CLEAR.
Set objEmail = Nothing: Set objOutlook = Nothing
ErrHandler:
'
End Sub
as in the comments Ron has this figured. The bellow code and function does the trick. Copy them both
Private Sub CommandButton1_Click()
' SET Outlook APPLICATION OBJECT.
Dim rng As Range
Dim objOutlook As Object
Set objOutlook = CreateObject("Outlook.Application")
Set rng = Nothing
On Error Resume Next
Set rng = ActiveSheet.Range("A11:H12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
' CREATE EMAIL OBJECT.
Dim objEmail As Object
Set objEmail = objOutlook.CreateItem(olMailItem)
With objEmail
.To = "email"
.Subject = "test"
.HTMLBody = RangetoHTML(rng)
.Display ' DISPLAY MESSAGE.
End With
' CLEAR.
Set objEmail = Nothing:
Set objOutlook = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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
Code:
Sub sendEmail()
'call outlook
Dim MyOlapp As Object, MyItem As Object
Set MyOlapp = CreateObject("Outlook.Application")
Set MyItem = MyOlapp.CreateItem(olMailItem)
'ajust range of sheet
Range("A11:H12").Select
Selection.Copy
With MyItem
'ajust number of sheet
.To = Sheet17.[b1].Value 'e-mail adress
.Subject = Sheet17.[b2].Value 'subject of e-mail
.Body = Sheet17.[b3].Value 'body of e-mail
.Display
SendKeys ("^{DOWN}")
SendKeys ("^{DOWN}")
SendKeys ("%m")
SendKeys ("v")
SendKeys ("s")
SendKeys ("{UP}")
SendKeys ("{UP}")
SendKeys ("{ENTER}")
SendKeys ("{ENTER}")
SendKeys ("%m")
SendKeys ("q")
SendKeys ("{ENTER}")
End With
End Sub
Related
How can I changed my email body with copy of selection of cells (A1:H59) without loosing their formats.
The below code works good for rest of the email just not the email body part. I just need to include Range A1 to H59 from the Activesheet into the email body.
With obMail
.To = Range("B14").Value
.Subject = "Outstanding Balance"
Range("A1:H59").Select
Selection.Copy
.HTMLBody = Selection.PasteSpecial
.SentOnBehalfOfName = "myemail#company.com"
.Send
End With
Use HTML for something like this.
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'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-2016
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
https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
I have a excel table in Range("A1:H13"). How should I write the code to paste this table as picture in mailbody. My code look like this:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Subject = Range("K1").Value
.To = Range("K2").Value
.Cc = Range("K3").Value
.Bcc = Range("K4").Value
.Body = Range("A1:H13").Value
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
I can think of a couple ways to do this. Try the script below. That is probably your best best for this kind of thing.
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'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-2016
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
https://www.rondebruin.nl/win/s1/outlook/bmail2.htm
I have a scrip to sent mail from excel via outlook .
Here i select a cell and copy it as html and sent to outlook .
but in hangs in method Function RangetoHTML(rng As Range) at line RangetoHTML = ts.readall when no. of row are upto 70 .
Can someone help.
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'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 = "xxxxx#xxxxx.com"
.BCC = ""
.Subject = "Report" & Format(Now, "dd-MM-yyyy")
.HTMLBody = RangetoHTML(rng)
.Display 'or use .Display .Send
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-2016
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim SignatureFilePath As String
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
SignatureFilePath = "Office.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 // hangs here
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
RangetoHTML = "<BODY style= color:black;font-size:11.0pt;font-weight:400;font-family:Consolas,monospace>Dear Chetan<p>Please find details<p> </BODY>" & RangetoHTML & "<br><br>" & GetSignature(SignatureFilePath)
'Close TempWB
TempWB.Close savechanges:=False
Debug.Print
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function GetSignature(fPath As String) As String
Dim fso As Object
Dim TSet As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set TSet = fso.GetFile(fPath).OpenAsTextStream(1, -2)
GetSignature = TSet.readall
TSet.Close
End Function
This will copy & paste the selection from Excel to the Outlook email body, preserving your default signature (if there is one). If you need to add some other signature from file location, you'd need some additional magic.
With OutMail
.To = "xxxxx#xxxxx.com"
.BCC = ""
.Subject = "Report" & Format(Now, "dd-MM-yyyy")
.Display 'or use .Display .Send
Dim wdDoc As Object '## Word.Document
Dim wdRange As Object '## Word.Range
Set wdDoc = OutMail.GetInspector.WordEditor
Set wdRange = wdDoc.Range(0, 0)
wdRange.InsertAfter vbCrLf & vbCrLf
'Copy the range in-place
rng.Copy
wdRange.Paste
End With
Alternatively, copy the data to a new worksheet and send as attachment:
Sub SendAsAttachment()
Dim rng As Range
Dim newWB As Workbook
Dim newWS As Worksheet
On Error Resume Next
Set rng = Selection.SpecialCells(xlCellTypeVisible)
If Err.Number <> 0 Then Exit Sub
On Error GoTo 0
Set newWB = Workbooks.Add
With newWB
Set newWS = .Sheets(1)
newWS.Name = rng.Parent.Name
rng.Copy newWS.Range("A1")
Do While .Worksheets.Count > 1
.Worksheets(.Count).Delete
Loop
.SendMail "david.zemens#jdpa.com", "subject", False
.Close False
End With
End Sub
The latter method does not include signature line in the email, though.
I'm trying to create a vba macro which generates a meeting invite that uses variable data from a worksheet.
My first problem is that it only opens up as an appointment, but not as a meeting with the invitees listed (however, if i click "Invite Attendees" on the appointment, they are prepopulated).
My second problem is that the required information I want in the body does not display.
Below is the code, can anyone assist?
Sub Consolidation_Invite()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim objMyApptItem As Object
Dim recipients As Range
Set rng = Nothing
On Error Resume Next
'You can use a fixed range or the visible cells in the selection
'Selection.SpecialCells(xlCellTypeVisible)
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
Set rng = Sheets("Calendar Invite").Range("A21:B50").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 objMyApptItem = OutApp.CreateItem(1)
Set recipients = Worksheets("Calendar Invite").Range("B11")
On Error Resume Next
With objMyApptItem
.MeetingStatus = olMeeting
.recipients.Add recipients
.Location = " Phone Call"
.Subject = Worksheets("Calendar Invite").Range("B13")
.Start = Worksheets("Calendar Invite").Range("B15")
.AllDayEvent = "False"
.HTMLBody = RangetoHTML(rng)
.Display 'or use .Send
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-2016
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
It IS a meeting request. The MeetingItem object cannot be created, it is automatically created when you set the MeetingStatus property of an AppointmentItem object to olMeeting and send it to one or more users. Recipients will receive them as MeetingItem items.
For your second problem, the AppointmentItem object doesn't support an HTMLBody property; only Body and RTFBody.
I figured it out, so posting the solution in case others wish to use the same. Basically as you can't use HTMLBody, you can compose in Word. So this will copy and paste in the word editor.
I still can't get it to display the invitees by default... but clicking the "Invite Attendees" button isn't such a bit deal.
Sub Consolidation_Invite()
Dim olApp As Object
Dim olApt As Object
Dim RCP As Range
Const wdPASTERTF As Long = 1
Set olApp = CreateObject("Outlook.Application")
Set olApt = olApp.CreateItem(1)
Set RCP = Worksheets("Calendar Invite").Range("B11")
With olApt
.MeetingStatus = olMeeting
.Start = Worksheets("Calendar Invite").Range("B15")
.AllDayEvent = "False"
.recipients.Add RCP
.Location = "Phone Call (please be at your computer)"
.Subject = Worksheets("Calendar Invite").Range("B13")
Sheets("Calendar Invite").Range("A21:B50").Copy
.Display
.GetInspector.WordEditor.Windows(1).Selection.PasteAndFormat wdPASTERTF
End With
End Sub
I have been working and did some Google searches to create code that sends an automatic email with information from my active Excel sheet. The code prepares the email properly, but I still need to press "Send" on the email. I would like to send it automatically, so I tried to add .Send on the code, but it didn't work.
At the moment my code looks like that:
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngCc As Range
Dim rngSubject As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("t2")
Set rngSubject = .Range("t3")
Set rngBody = .Range("a1:r35")
End With
rngBody.Copy
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.Display
End With
SendKeys "^({v})", True
.Send
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngCc = Nothing
Set rngSubject = Nothing
Set rngBody = Nothing
End Sub
With objMail
.To = rngTo.Value
.Subject = rngSubject.Value
.body = rngBody.Value
.Send
End With
Should do the trick. (Note: I set the body of the message, since you seemed to have missed that.)
remove these lines:
SendKeys "^({v})", True
.Send
The Outlook object model provides three different ways for working with item bodies:
Body - a plain text.
HTMLBody - an HTML markup.
The Word Editor. Outlook uses Word as an email editor, so you can use it to format the email message. The WordEditor property of the Inspector class returns an instance of the Document class which represents the message body.
You can read more about all these ways in the Chapter 17: Working with Item Bodies in MSDN.
The simplest way to get the job done is to use the Word object model for modifying the message body. For example:
mail.GetInspector().WordEditor
Then you can use the Word object model for working with message body.
Finally, you need to call the Send method to submit the message for processing by the transport provider.
here is complete code that is working for me.
Option Explicit
Sub CreateMail()
Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngCc As Range
Dim rngBCC As Range
Dim rngSubject As Range
Dim rngBody As Range
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With ActiveSheet
Set rngTo = .Range("T2")
Set rngCc = .Range("T2")
Set rngBCC = .Range("T2")
Set rngSubject = .Range("T3")
Set rngBody = .Range("A1:R35")
End With
rngBody.Copy
With objMail
.To = rngTo.Value
.CC = rngCc.Value
.BCC = rngBCC.Value
.Subject = rngSubject.Value
.HTMLBody = RangetoHTML(rngBody)
ActiveWorkbook.Save
.Send
End With
Set objOutlook = Nothing
Set objMail = Nothing
Set rngTo = Nothing
Set rngCc = Nothing
Set rngSubject = Nothing
Set rngBody = 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") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".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
Cells(1).Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
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