Option Explicit
Sub Emails()
Dim i As Long
Dim OutlookApp As Object
Dim OutlookItem As Object
Const OutlookMailItem As Long = 0
Dim intChoice As Integer
Dim 1TemplatePathAnswer As Integer
Dim 1TemplatePath As String
Dim 2TemplatePathAnswer As Integer
Dim 2TemplatePath As String
Dim 2Contact As String
Dim rng As Range
1TemplatePathAnswer = MsgBox("Do you know the path for the #1 email template?", vbYesNoCancel + vbQuestion, _
"Please Respond")
If 1TemplatePathAnswer = vbYes Then
'Get filepath for the RFI
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = "C:\Users\" & Environ$("Username") & "\AppData\Roaming\Microsoft\Templates"
.AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
1TemplatePath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Else: End
End If
End With
ElseIf 1TemplatePathAnswer = vbCancel Then
Exit Sub
ElseIf 1TemplatePathAnswer = vbNo Then
MsgBox ("You will need to know the location of the email template to use this macro.")
Exit Sub
End If
2TemplatePathAnswer = MsgBox("Do you know the path for the #2 email template?", vbYesNoCancel + vbQuestion, _
"Please Respond")
If 2TemplatePathAnswer = vbYes Then
'Get filepath for the RFI
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = "C:\Users\" & Environ$("Username") & "\AppData\Roaming\Microsoft\Templates"
.AllowMultiSelect = False
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
2TemplatePath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Else: End
End If
End With
ElseIf 2TemplatePathAnswer = vbCancel Then
Exit Sub
ElseIf 2TemplatePathAnswer = vbNo Then
MsgBox ("You will need to know the location of the email template to use this macro.")
Exit Sub
End If
'Step 1: Initialize an Outlook session.
Set OutlookApp = CreateObject("Outlook.Application")
'Step 2: For each non-empty cell in the range, create a new message.
Range("A2").Select
Do Until IsEmpty(ActiveCell)
2Contact = ActiveCell.Offset(0, 7).Value
Do Until ActiveCell.Offset(0, 7).Value <> 2Contact
Set OutlookItem = OutlookApp.CreateItemFromTemplate(1TemplatePath)
On Error Resume Next
With OutlookItem
'Step3: Add the To recipient(s) to message.
.To = ActiveCell.Offset(0, 2).Value
.HTMLBody = Replace(.HTMLBody, "%PLACEHOLDER1%", ActiveCell.Offset(0, 5).Value)
.HTMLBody = Replace(.HTMLBody, "%PLACEHOLDER2%", ActiveCell.Offset(0, 6).Value)
.HTMLBody = Replace(.HTMLBody, "%PLACEHOLDER3%", ActiveCell.Offset(0, 7).Value)
.Importance = olImportanceHigh 'High importance
.Display
End With
On Error GoTo 0
i = i + 1
ActiveCell.Offset(1, 0).Select
Loop
Set rng = Range(ActiveCell.Offset(-i, 0), ActiveCell.Offset(0, 2))
Set OutlookItem = OutlookApp.CreateItemFromTemplate(2TemplatePath)
With OutlookItem
'Step3: Add the To recipient(s) to message.
.To = 2Contact
.HTMLBody = Replace(.HTMLBody, "RANGETOHTML PLACEHOLDER", RangetoHTML(rng))
.HTMLBody = Replace(.HTMLBody, "PLACEHOLDER1", ActiveCell.Offset(0, 5))
.Importance = olImportanceHigh 'High importance
.Display
End With
i = 0
2Contact = ActiveCell.Offset(0, 7).Value
Loop
Set OutlookApp = Nothing
Set OutlookItem = 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
Set TempWB = Workbooks.Add(1)
rng.Copy
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
Bookmarks