Paste Excel range as picture into email body - excel

My aim is to paste a range as an image into an Outlook email. I turned on the references in the VBA editor for MS Excel, Word and Outlook 15.0 as my latest version on my network.
I've spent hours looking through previously answered similar questions.
I cannot save the image as a temporary file/use html to reference the attachment as a solution due to other users not having access to specific drives where it would be temporarily saved if they ran the code on their own machines.
If I remove the email body section the image pastes fine however if I have both pieces of code in together, the email body writes over the image. I do however need the image to be pasted within the email body text.
Sub CreateEmail()
Dim OlApp As Object
Dim OlMail As Object
Dim ToRecipient As Variant
Dim CcRecipient As Variant
Dim PictureRange As Range
Dim OApp As Object, OMail As Object, signature As String
Set OlApp = CreateObject("Outlook.Application")
Set OlMail = OlApp.createitem(olmailitem)
ExtractName = ActiveWorkbook.Sheets("macros").Range("C11").Value
ToRecipient = ActiveWorkbook.Sheets("macros").Range("K11")
OlMail.Recipients.Add ToRecipient
CC_Check = ActiveWorkbook.Sheets("macros").Range("k10")
If CC_Check = "" Then GoTo Skip_CC
CcRecipient = ActiveWorkbook.Sheets("macros").Range("K10")
OlMail.Recipients.Add CcRecipient
OlMail.Subject = ExtractName
signature = OlMailbody
With OlMail
Set PictureRange = ActiveWorkbook.Sheets("DCTVV").Range("A2:D13")
PictureRange.Copy
OlMail.Display
'This section pastes the image
Dim wordDoc As Word.Document
Set wordDoc = OlMail.GetInspector.WordEditor
wordDoc.Range.PasteAndFormat wdChartPicture
'This section is the email body it needs inserting into
OlMail.body = "Text here," & vbNewLine & vbNewLine & _
"Today's report is attached." & vbNewLine & _
"IMAGE NEEDS TO BE PASTED HERE" _
& vbNewLine & vbNewLine & "More text here" _
& vbNewLine & vbNewLine & "Kind regards,"
.signature
End With
Set OMail = Nothing
Set OApp = Nothing
OlMail.Attachments.Add ("filepath &attachment1")
OlMail.Attachments.Add ("filepath &attachment2")
'OlMail.Attachments.Add ("filepath &attachment3")
OlMail.Display
End Sub

From what I understand the picture pastes fine to email's body, right?
In this case you might just need to add .HTMLBody like so:
olMail.HTMLBody = "Text here," & vbNewLine & vbNewLine & _
"Today's report is attached." & vbNewLine & _
.HTMLBody & _
vbNewLine & vbNewLine & "More text here" & _
vbNewLine & vbNewLine & "Kind regards,"

This is an example of my code that we use on my job te send emails:
Call CrearImagen
ReDim myFileList(0 To Contador - 1)
For i = 0 To Contador - 1
myFileList(i) = wb.Path & "\" & Servicio & i & ".jpg"
ImagenesBody = ImagenesBody & "<img src='cid:" & Servicio & i & ".jpg'>"
Next i
With OutMail
.SentOnBehalfOfName = "ifyouwanttosendonbehalf"
.Display
.To = Para
.CC = CC
.BCC = ""
.Subject = Asunto
For i = 0 To UBound(myFileList)
.Attachments.Add myFileList(i)
Next i
Dim Espacios As String
Espacios = "<br>"
For i = 0 To x
Espacios = Espacios + "<br>"
Next
.HTMLBody = Saludo & "<br><br>" & strbody & "<br><br><br>" _
& ImagenesBody _ 'here are the images
& Espacios _ 'more text
& .HTMLBody
.Display
End With
On Error GoTo 0
'Reformateamos el tamaño de las imagénes y su posición relativa al texto
Dim oL As Outlook.Application
Set oL = GetObject("", "Outlook.application")
Const wdInlineShapePicture = 3
Dim olkMsg As Outlook.MailItem, wrdDoc As Object, wrdShp As Object
Set olkMsg = oL.Application.ActiveInspector.CurrentItem
Set wrdDoc = olkMsg.GetInspector.WordEditor
For Each wrdShp In wrdDoc.InlineShapes
If wrdShp.Type = wdInlineShapePicture Then
wrdShp.ScaleHeight = 100
wrdShp.ScaleWidth = 100
End If
If wrdShp.AlternativeText Like "cid:Imagen*.jpg" Then wrdShp.ConvertToShape
Next
'Limpiamos los objetos
For i = 0 To UBound(myFileList)
Kill myFileList(i)
Next i
Set olkMsg = Nothing
Set wrdDoc = Nothing
Set wrdShp = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
Now if you can already create the images, just save them on the workbook path and you can attach them like this. When attaching images I suggest you that the names of the files don't contain spaces, found out this the hard way until figured it out, html won't like them with spaces.

If your code suddenly stopped working after migrating to Office 365 or for any other reasons, please refer to the code below. Comments have been added for easy understanding and implementation.
If you have administrative rights then try the registry changes given at below link:
https://support.microsoft.com/en-au/help/926512/information-for-administrators-about-e-mail-security-settings-in-outlo
However, as developer, I recommend a code that's rather compatible with all versions of Excel instead of making system changes because system changes will be required on each end user's machine as well.
As the VBA code below use 'Late Binding', it's also compatible with all previous and current versions of MS Office viz. Excel 2003, Excel 2007, Excel 2010, Excel 2013, Excel 2016, Office 365
Option Explicit
Sub Create_Email(ByVal strTo As String, ByVal strSubject As String)
Dim rngToPicture As Range
Dim outlookApp As Object
Dim Outmail As Object
Dim strTempFilePath As String
Dim strTempFileName As String
'Name it anything, doesn't matter
strTempFileName = "RangeAsPNG"
'rngToPicture is defined as NAMED RANGE in the workbook, do modify this name before use
Set rngToPicture = Range("rngToPicture")
Set outlookApp = CreateObject("Outlook.Application")
Set Outmail = outlookApp.CreateItem(olMailItem)
'Create an email
With Outmail
.To = strTo
.Subject = strSubject
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
.Attachments.Add strTempFilePath, olByValue, 0
'Change the HTML below to add Header (Dear John) or signature (Kind Regards) using newline tag (<br />)
.HTMLBody = "<img src='cid:" & strTempFileName & ".png' style='border:0'>"
.Display
End With
Set Outmail = Nothing
Set outlookApp = Nothing
Set rngToPicture = Nothing
End Sub
Sub createPNG(ByRef rngToPicture As Range, nameFile As String)
Dim wksName As String
wksName = rngToPicture.Parent.Name
'Delete the existing PNG file of same name, if exists
On Error Resume Next
Kill Environ$("temp") & "\" & nameFile & ".png"
On Error GoTo 0
'Copy the range as picture
rngToPicture.CopyPicture
'Paste the picture in Chart area of same dimensions
With ThisWorkbook.Worksheets(wksName).ChartObjects.Add(rngToPicture.Left, rngToPicture.Top, rngToPicture.Width, rngToPicture.Height)
.Activate
.Chart.Paste
'Export the chart as PNG File to Temp folder
.Chart.Export Environ$("temp") & "\" & nameFile & ".png", "PNG"
End With
Worksheets(wksName).ChartObjects(Worksheets(wksName).ChartObjects.Count).Delete
End Sub

Related

Outlook embedded picture from Excel not showing in mail outside organisation

I am using a macro to compose a report based on an excel file. The macro uses a body with text and a picture (png) from an predefined Excel range.
This used to work perfect but now I have to share the report outside of my organization i get feedback that the image is not showing.
Does anybody know if this is due to the macro or not?
I have tested this also to my hotmail and gmail accounts and it is not showing there as well?
Sub Mail_()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim SigString As String
Dim Signature As String
Dim Adm As Worksheet
Dim Body As String
Dim Body2 As String
Dim Body3 As String
Dim Body4 As String
Dim rngToPicture As Range
Dim rng2 As Range
Dim Weeknr As String
Dim strTempFilePath As String
Dim strTempFileName As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set Adm = ActiveWorkbook.Worksheets("Uit")
Set rngToPicture = Adm.Range("X13:AT65")
Adm.Activate
ActiveWindow.Zoom = 100
strTempFileName = "RangeAsPNG"
Weeknr = Adm.Range("AF3").Text
Body = Adm.Range("X6:X6").Text
Body2 = Adm.Range("X8:X8").Text
Body3 = Adm.Range("X9:X9").Text
Body4 = Adm.Range("X11:X11").Text
strbody = "<BODY style=font-size:10pt;font-family:Verdana>" & Body & _
"<br><br>" & Body2 & "<br>" & Body3 & "<br><br>" & Body4 & "<br><br>"
'Change only Mysig.htm to the name of your signature
SigString = Environ("appdata") & _
"\Microsoft\Handtekeningen\Servicekantoor.htm"
Signature = GetBoiler(SigString)
On Error Resume Next
With OutMail
.to = "Mailinglist#list.com"
.CC = ""
.BCC = ""
.Subject = "Weekly report " & Weeknr
'Create the range as a PNG file and store it in temp folder
Call createPNG(rngToPicture, strTempFileName)
'Embed the image in Outlook
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
.Attachments.Add strTempFilePath, olByValue, 0
.HTMLBody = strbody & "<br><br>" & "<img src='cid:" & strTempFileName & ".png'
style='border:0'>" & "<br><br>" & Signature
.Recipients.ResolveAll
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You are close - the cid in the src attribute must be not the file name (which is not visible to the outside users), but some value that matches the PR_ATTACH_CONTENT_ID property on the attachment:
strTempFilePath = Environ$("temp") & "\" & strTempFileName & ".png"
set Attach = .Attachments.Add(strTempFilePath, olByValue)
Attach.PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x3712001F", "MyCid"
.HTMLBody = strbody & "<br><br>" & "<img src='cid:MyCid' style='border:0'>" & "<br><br>" & Signature

Adding an image between text in email

I have used both the .body and .HTMLbody. With both approaches I managed to get only 90% of what I want. I prefer using .HTMLBody as it allows the signature to be populated.
Below is the coding from various online tutorials/vids.
Sub CopyRangeToOutlook_Client 1()
Dim oLookApp As Outlook.Application
Dim oLookItm As Outlook.MailItem
Dim oLookIns As Outlook.Inspector
Dim signature As String
Dim oWrdDoc As Word.Document
Dim oWrdRng As Word.Range
Dim ExcRng As Range
On Error Resume Next
Set oLookApp = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Err.Clear
Set oLookApp = New Outlook.Application
End If
Set oLookItm = oLookApp.CreateItem(olMailItem)
signature = oLookItm.Body
Set ExcRng = Sheet3.Range("A1:E26")
strbody = "<BODY style = font-size:14pt;Color:RGB(96,97,96)>" & _
"Dear Client,<p> I trust you are well.<p>" & _
"Please see below ............. weekly reference rates.<p>" & _
"Kind Regards"
With oLookItm
.Display
.To = "xxxxxxxxxxxxx.com"
.CC = "xxxxxxxxxxxxx.com"
.Subject = "xxxxxxxxxxxxxxxx // xxxxxxxxxxxxxxxx (Pty) Ltd - Weekly Reference Rate" & " - " &
Format(Date, "(dd-mm-yyyy)")
.HTMLBody = strbody & _
.HTMLBody
Set oLookIns = .GetInspector
Set oWrdDoc = oLookIns.WordEditor
Set oWrdRng = oWrdDoc.Application.activeDocument.Content
oWrdRng.collapse Direction:=wdCollapseEnd
Set oWrdRng = oWdEditors.Paragraphs.Add
ExcRng.Copy
oWrdRng.PasteSpecial DataType:=wdPasteMetafilePicture
End With
End Sub
The email is created using the .HTMLBody format with the defined context in the strbod0y with the desired signature at the bottom.
The Excel range extracted as the image appears after the signature section.
I would like it between the text as defined in the strbody or if it is possible to mark the space between the text and paste the image at the preserved "location".
Here is a way you could do it.
Sub Demo()
Dim Body As String
' Define your email body, use placeholder
' where you want image to go, e.g. [IMAGE]
Body = "<BODY style = font-size:14pt;Color:RGB(96,97,96)>" & _
"Dear Client,<p> I trust you are well.</p>" & _
"<p>Please see below ............. weekly reference rates.</p>" & _
"[IMAGE]" & _
"<p>Kind Regards</p>"
With CreateObject("Outlook.Application").CreateItem(0)
.Display
.To = "xxxxxxxxxxxxx.com"
.CC = "xxxxxxxxxxxxx.com"
.Subject = "xxxxxxxxxxxxxxxx // xxxxxxxxxxxxxxxx (Pty) Ltd - Weekly Reference Rate" & " - " & _
Format(Date, "(dd-mm-yyyy)")
.HTMLBody = Body & .HTMLBody
With .GetInspector.WordEditor.Content
' If the placeholder exists...
If .Find.Execute("[IMAGE]") Then
' Copy image from Excel
Sheets("Sheet3").Shapes("Picture 1").CopyPicture
' Paste over placeholder
.Paste
End If
End With
End With
End Sub

Run same macro in different versions of Excel / Outlook / Word

I generate reports to send to different branches. I run a macro that creates protected reports (*.xlsm). These reports have a space for comments for the Branch Managers, with a "send Comments" button that run this macro below.
I suggested the following references to add if the macro does not work.
The Branch Managers have different versions of MS Office (Excel, Outlook, etc.) on their laptops. When they try to Run, it shows errors, such as: "Error in Loadind DLL"; Error2, etc.
What should be done on the Branch Managers side to run this Macro?
Sub CommentsEmail()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OutApp As Object
Dim OutMail As Object
Dim olApp As Outlook.Application
Dim mymail As Outlook.mailItem
Dim objSel As Word.Selection
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Shell ("Outlook")
Set olApp = New Outlook.Application
Set mymail = olApp.CreateItem(olMailItem)
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
template.Activate
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'OutMail.Display
Dim wordDoc As Word.Document
Set wordDoc = OutMail.GetInspector.WordEditor
Set objSel = wordDoc.Windows(1).Selection
'construct the body of the email here
With objSel
'first text
.InsertAfter "Dear All," & vbCrLf
.Move wdParagraph, 1
'second text
.InsertAfter vbCrLf & "See below the Comments for Flash Indicator - " & branch & vbCrLf & vbCrLf
.Move wdParagraph, 1
'copy a range and paste a picture
commentsrange.Copy ''again, you need to modify your target range
.PasteAndFormat wdChartPicture
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Let us know of any questions." & vbCrLf & vbCrLf
.Move wdParagraph, 1
.InsertAfter vbCrLf & "Kind Regards," & vbCrLf
End With
OutMail.To = OutMail.To & ";" & Sendto
With OutMail
.Subject = "Comments on Flash Indicator Results - " & branch
.Attachments.Add (ActiveWorkbook.FullName)
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Is this still early binding? If yes, I am totally lost.
Sub CommentsEmail2()
Dim template As Workbook
Dim dashboard As Worksheet
Dim comments As Worksheet
Dim OlaApp As Object
Dim OleMail As Object
Dim TempFilePath As String
Dim xHTMLBody As String
Dim commentsrange As Range
Dim branch As String
Dim Sendto As String
UpdateScreen = False
Set template = ActiveWorkbook
Set dashboard = template.Worksheets("Dashboard")
Set comments = template.Worksheets("Comments")
Set commentsrange = comments.Range(Cells(7, 1), Cells(52, 4))
branch = dashboard.Cells(1, 25)
Sendto = comments.Cells(2, 10)
template.Activate
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
Set OleMail = olApp.CreateItem(0)
Call createJpg(ActiveSheet.comments, commentsrange, "DashboardFile")
TempFilePath = Environ$("temp") & "\"
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello, this is the data range that you want:<br> " _
& "<br>" _
& "<img src='cid:DashboardFile.jpg'>" _
& "<br>Best Regards!</font></span>"
With OleMail
.Subject = "test"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.Attachments.Add (ActiveWorkbook.FullName)
.To = " "
.Cc = " "
.Display
End With
Set OleMail = Nothing
Set OlaApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Exit Sub
End Sub
Sub createJpg(SheetName As String, commentsrange As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(comments).Activate
Set xRgPic = ThisWorkbook.Worksheets(comments).Range(Cells(7, 1), Cells(52, 4))
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(comments).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets(comments).ChartObjects(Worksheets(comments).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub

Copy Excel graph to Outlook not showing. show "X"

I have use the below macro to copy graph into picture and text to outlook to send out. I have set the emails to myself and 2 other recipient.
I am manage to see those graph, however the other 2 recipient cannot see the graph. they see it as a cross (X) in a box. my temp files isn't deleted so I don't know why they see cross in the image of the graph
Sub SendChart_As_Body_UsingOutlook()
Dim rng As Range
Dim olApp As Object
Dim NewMail As Object
Dim ChartName As String
Dim ChartName1 As String
Set rng = Range("A1:AQ45").SpecialCells(xlCellTypeVisible)
Set olApp = CreateObject("Outlook.Application")
'fill in the file path/name of the gif file
ChartName = Environ$("temp") & "\Chart.gif"
ChartName1 = Environ$("temp") & "\Chart1.gif"
ActiveWorkbook.Worksheets("feb 18").ChartObjects("Chart 1").Chart.Export _
Filename:=ChartName, FilterName:="JPEG"
ActiveWorkbook.Worksheets("feb 18").ChartObjects("Chart 2").Chart.Export _
Filename:=ChartName1, FilterName:="JPEG"
' Create a new mail message item.
Set NewMail = olApp.CreateItem(0)
With NewMail
.Subject = "copy graph and text - Auto"
.To = "meme#xxx.com; reciep1#xxx.com; reciept2#xxx.com"
.HTMLBody = RangetoHTML(rng) & "<img src=" & "'" & ChartName1 & "'>" & "<img src=" & "'" & ChartName & "'>"
.send
End With
'Now delete the chart image from the temp folder
'Kill ChartName
'Release memory.
Set olApp = Nothing
Set NewMail = Nothing
End Sub
The problem is that you're just creating a link to the image on your PC, not embedding the image in the e-mail. You need to include an Attachments.Add line in your VBA. See embedded Images in html email from Excel VBA .
Try something like this
With NewMail
.Subject = "copy graph and text - Auto"
.To = "meme#xxx.com; reciep1#xxx.com; reciept2#xxx.com"
.Attachments.Add ChartName, olByValue, 0
.Attachments.Add ChartName1, olByValue, 0
.HTMLBody = "<body>" & RangetoHTML(Rng) & _
"<img src=" & "'" & ChartName1 & "'>" & _
"<img src=" & "'" & ChartName & "'> </body>"
.Display
End With
Here is another examples using Word object
https://stackoverflow.com/a/48897439/4539709
https://stackoverflow.com/a/40052843/4539709

Excel VBA For Each Case Send Email

Hi I am using the below code to send multiple emails based on different cases. (Email addressess and other information are stored in a worksheet) The code works fine however I have 20 different cases (example below only shows two). Putting the outlook application code within each case seems cumbersome.
Is there a method to perform the email against each case without having to express the outlook code within each case?
I have searched using For Each Case without any luck. Help is greatly appreciated.
Sub RequestUpdates()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim blRunning As Boolean
Dim email As String
Dim fname As String
Dim fllink As String
Dim cpname As String
Dim v As Integer
Dim y As Integer
Dim rng As Range
Dim rdate As Date
Dim signature As String
v = Sheets("Contributors").Range("A" & Rows.Count).End(xlUp).Row
Set rng = Sheets("Contributors").Range("A1")
rdate = Sheets("Contributors").Range("A1").Value
For y = 0 To v
Select Case rng.Offset(1 + y, 0).Value
Case "PCR"
email = Sheets("Contributors").Range("E4").Value
fname = Sheets("Contributors").Range("D4").Value
fllink = Sheets("Contributors").Range("F4").Value
cpname = Sheets("Contributors").Range("B4").Value
'get application
blRunning = True
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
Set olApp = New Outlook.Application
blRunning = False
End If
On Error GoTo 0
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.Display
End With
signature = olMail.HTMLBody
With olMail
'Specify the email subject
.Subject = "test " & rdate
'Specify who it should be sent to
'Repeat this line to add further recipients
.Recipients.Add email
'specify the file to attach
'repeat this line to add further attachments
'.Attachments.Add "LinktoAttachment"
'specify the text to appear in the email
.HTMLBody = "<p>Hi " & fname & ",</p>" & _
"<P>Please follow the link below to update the " & cpname & " test" _
& "For month ending " & rdate & ".</p>" & _
"<P> </br> </p>" & _
fllink & _
"<P> </br> </p>" & _
"<p>If you face issues with file access please contact me directly.</p>" & _
"<P>Note: xxxxx.</p>" & _
signature
'Choose which of the following 2 lines to have commented out
.Display 'This will display the message for you to check and send yourself
'.Send ' This will send the message straight away
End With
Case "NFG"
email = Sheets("Contributors").Range("E6").Value
fname = Sheets("Contributors").Range("D6").Value
fllink = Sheets("Contributors").Range("F6").Value
cpname = Sheets("Contributors").Range("B6").Value
'get application
blRunning = True
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
Set olApp = New Outlook.Application
blRunning = False
End If
On Error GoTo 0
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.Display
End With
signature = olMail.HTMLBody
With olMail
'Specify the email subject
.Subject = "Test" & rdate
'Specify who it should be sent to
'Repeat this line to add further recipients
.Recipients.Add email
'specify the file to attach
'repeat this line to add further attachments
'.Attachments.Add "LinktoAttachment"
'specify the text to appear in the email
.HTMLBody = "<p>Hi " & fname & ",</p>" & _
"<P>Please follow the link below to update the " & cpname & " component Test" _
& "For month ending " & rdate & ".</p>" & _
"<P> </br> </p>" & _
fllink & _
"<P> </br> </p>" & _
"<p>If you face issues with file access please contact me directly.</p>" & _
"<P>Note: Test.</p>" & _
signature
'Choose which of the following 2 lines to have commented out
.Display 'This will display the message for you to check and send yourself
'.Send ' This will send the message straight away
End With
End Select
Next
End Sub
I see two cases you showed follow one template, how about creating sub which sends emails retreiving subject, to etc. from parameters and then calling it from within Select Case with proper values passed?

Resources