Back to jkp-ads.com |
Ron de Bruin
|
Ron de Bruin decided to remove all Windows Excel content from his website for personal reasons. If you want to know why, head over to rondebruin.nl.
Luckily, Ron was kind enough to allow me to publish all of his Excel content here.
Most of these pages are slightly outdated and may contain links that don 't work. Please inform me if you find such an error and I'll try to fix it.
Kind regards
Jan Karel Pieterse
Important read this :
The code on this page is only working when you use Outlook as your mail
program.
Copy the code in a Standard module of your workbook, if you just
started with VBA see this page.
Where do I paste
the code that I find on the internet
Check out this Tip page for changing the code on this page.
Tips for changing the code examples
The following subroutine sends the visible cells in the selection in the
body of the mail without pictures. Don't forget to copy the function
RangetoHTML in the same module. You only have to change the mail address in
the macro and select a few cells before you can run the macro.
If you
use Office 2002-2016 see this page for an example
with pictures.
Important: Be aware that if you have
set Excel to R1C1 reference style the code will not work.
You can add
this line at the start of your macro to be sure it is set to xlA1 style
Application.ReferenceStyle = xlA1
And
this one to set it back if you need
Application.ReferenceStyle = xlR1C1
Note:
Read also the information below the macro
Sub Mail_Selection_Range_Outlook_Body() 'For Tips see: https://jkp-ads.com/rdb/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
If you want to add a few text lines above the HTML body you can add this
to the macro. Note: This is not working if Microsoft Word
is your mail editor in Outlook 2000-2003, you can change this setting in
Outlook: Tools>Options>…..Mail Format tab
Add this Dim line
Dim StrBody As String
Build the string you want to add
StrBody = "This is line 1" & "<br>" & _ "This is line 2" & "<br>" & _ "This is line 3" & "<br><br><br>"
Or use this for cell values
StrBody = Sheets("Sheet2").Range("A1").Value & "<br>" & _ Sheets("Sheet2").Range("A2").Value & "<br>" & _ Sheets("Sheet2").Range("A3").Value & "<br><br><br>"
And change the HTMLBody line to this
.HTMLBody = StrBody & RangetoHTML(rng)
If you want to use the Intellisense help showing you the properties and
methods of the objects as you type you can use Early Binding.
Bit faster also when you run your code but you can have problems when you
distribute your workbooks. Excel will automatic update the reference number
to Outlook when you open your workbook in a higher version of Excel/Outlook
but not update it when you open it in a lower version of Excel/Outlook. With
Late Binding as I used in the macro examples you not have
this problem.
Add a reference to the Microsoft Outlook Library in
Excel
1) Go to the VBA editor with the shortcut
Alt - F11
2) Click on
Tools>References in the Menu bar
3) Place a
Checkmark before Microsoft Outlook ? Object Library
Where ? is the Outlook version number
Then replace
this three lines in the code
Dim OutApp As
Object
Dim OutMail As Object
Set OutMail = OutApp.CreateItem(0)
With this three lines
Dim OutApp As
Outlook.Application
Dim OutMail As Outlook.MailItem
Set OutMail =
OutApp.CreateItem(olMailItem)