Problem sending pictures in email body

sharky12345

sharky12345

Well-known Member
Joined
Aug 5, 2010
Messages
3,431
Office Version
  1. 2016
Platform
  1. Windows
Guys,

The attached code, (courtesy of Ron de Bruin), attachs the named range into the body of an email message but I have a problem.

It is not including 2 pictures which are crucial to be included.

How can I achieve this?

Code: 
[FONT=Verdana][COLOR=black][COLOR=black][FONT=Courier New]Sub Mail_Selection_Range_Outlook_Body()<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]' Don't forget to copy the function RangetoHTML in the module.<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]' Working in Office 2000-2010<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Dim rng As Range<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Dim OutApp As Object<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Dim OutMail As Object<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set rng = Nothing<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] On Error Resume Next<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] 'Only the visible cells in the selection<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] 'You can also use a range if you want<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set rng = Sheets("Duties").Range("A1:Q21").SpecialCells(xlCellTypeVisible)<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] On Error GoTo 0<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] If rng Is Nothing Then<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     MsgBox "The selection is not a range or the sheet is protected" & _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]            vbNewLine & "please correct and try again.", vbOKOnly<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     Exit Sub<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] End If<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] With Application<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .EnableEvents = False<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .ScreenUpdating = False<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] End With<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set OutApp = CreateObject("Outlook.Application")<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set OutMail = OutApp.CreateItem(0)<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] On Error Resume Next<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] With OutMail<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .To = ""<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .CC = ""<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .BCC = ""<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .Subject = Sheets("Duties").Range("H2") & " - " & Sheets("Duties").Range("M2") & " Shift" & " Duties"<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .HTMLBody = RangetoHTML(rng)<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .Display<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] End With<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] On Error GoTo 0<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] With Application<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .EnableEvents = True<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .ScreenUpdating = True<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] End With<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set OutMail = Nothing<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set OutApp = Nothing<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]End Sub<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]Function RangetoHTML(rng As Range)<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Dim fso As Object<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Dim ts As Object<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Dim TempFile As String<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Dim TempWB As Workbook<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] ' Copy the range and create a workbook to receive the data.<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] rng.Copy<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set TempWB = Workbooks.Add(1)<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] With TempWB.Sheets(1)<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .Cells(1).PasteSpecial Paste:=8<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .Cells(1).PasteSpecial xlPasteValues, , False, False<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .Cells(1).PasteSpecial xlPasteFormats, , False, False<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .Cells(1).Select<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     Application.CutCopyMode = False<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     On Error Resume Next<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .DrawingObjects.Visible = True<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .DrawingObjects.Delete<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     On Error GoTo 0<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] End With<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] ' Publish the sheet to an .htm file.<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] With TempWB.PublishObjects.Add( _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]      SourceType:=xlSourceRange, _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]      Filename:=TempFile, _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]      Sheet:=TempWB.Sheets(1).Name, _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]      Source:=TempWB.Sheets(1).UsedRange.Address, _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]      HtmlType:=xlHtmlStatic)<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]     .Publish (True)<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] End With<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] ' Read all data from the .htm file into the RangetoHTML subroutine.<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set fso = CreateObject("Scripting.FileSystemObject")<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] RangetoHTML = ts.ReadAll<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] ts.Close<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]                       "align=left x:publishsource=")<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] ' Close TempWB.<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] TempWB.Close SaveChanges:=False<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] ' Delete the htm file.<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Kill TempFile<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set ts = Nothing<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set fso = Nothing<o:p></o:p>[/FONT][/COLOR]
[COLOR=black][FONT=Courier New] Set TempWB = Nothing[/FONT][/COLOR]
[COLOR=black][FONT=Courier New]End Function<o:p></o:p>[/FONT][/COLOR]
 
[/COLOR][/FONT]
 
Last edited:
Sort by date Sort by votes
Thanks Derek - I've looked at that thread and see what you mean!

I think I will shelve that idea and put up with the fact that I cannot do it easily!

Many thanks though - has saved me hours of searching.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Question Question
Two different worksheets with similar VBA's to send out emails getting Ambiguous name detected: RangetoHTML
Replies
1
Views
112
kac1125
K
D
  • Question Question
Ron de Bruin RANGETOHTML - TEXT FORMAT
Replies
0
Views
159
dudematters21
D
B
  • Question Question
VBA to delete attachment created on desktop
Replies
4
Views
138
bh24524
B
R
  • Question Question
Compose Email VBA Help
Replies
1
Views
372
Logit
Logit
earthworm
  • Question Question
Autofit table in Outlook upon copying from Excel sheet using Macro
Replies
1
Views
399
KOKOSEK
KOKOSEK

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top