Here's the code. I've also attached the sample workbook.
Code:
Option Explicit
'Requirement: Outlook needs to be loaded, and account logged in
Sub CallMailer()
Dim lngLoop As Long 'Programming ethics 1. Always start your first line after leaving a line space, and 1 indentation level
Dim varEmailList As Variant
Dim strSendTo As String
Dim blnSend As Boolean
With Worksheets("Sheet2")
varEmailList = .Range("A2:B" & .Cells(.Rows.Count, 1).End(xlUp).Row)
End With
With ActiveSheet
For lngLoop = 4 To .Cells(Rows.Count, 1).End(xlUp).Row ' Programming ethics 3. Always indent your loops, case statements and with constructors
strSendTo = Application.VLookup(.Cells(lngLoop, "E").Value, varEmailList, 2, 0)
If strSendTo <> vbNullString Then
If .Cells(lngLoop, "J").Value <> True And .Cells(lngLoop, "H").Value = Date Then
.Cells(lngLoop, "J").Value = True
blnSend = True
ElseIf .Cells(lngLoop, "K").Value <> True And .Cells(lngLoop, "I").Value = Date Then
.Cells(lngLoop, "K").Value = True
blnSend = True
End If
If blnSend Then
Call SendMessage(strTo:=strSendTo, strMessage:=CustMsg(.Cells(lngLoop, 2).Value, .Cells(lngLoop, 4).Value), strSubject:=.Cells(lngLoop, 3).Value, blnShowEmailBodyWithoutSending:=False, blnSignature:=True)
blnSend = False
End If
End If
strSendTo = vbNullString
Next lngLoop
End With 'Programming ethics 2. Always end your last line leaving a line space before ending the sub or function, and having indendation level of 1
End Sub
Function CustMsg(strB As String, strD As String)
Dim str As String
str = "Hi," & vbLf & vbLf
str = str & "This is regarding " & strB & ", " & strD & "."
str = str & vbLf & vbLf
CustMsg = str & "It is a gentle reminder. If you have any query, please let me know."
End Function
The send mail function which is more generic was picked from another thread in this forum. This is what it is
Code:
Option Explicit
Function SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional rngToCopy As Range, Optional strAttachmentPath As String, Optional blnShowEmailBodyWithoutSending As Boolean = False, Optional blnSignature As Boolean)
Dim objOutlook As Object 'Outlook.Application
Dim objOutlookMsg As Object 'Outlook.MailItem
Dim objOutlookRecip As Object 'Outlook.Recipient
Dim objOutlookAttach As Object 'Outlook.Attachment
Dim lngLoop As Long
Dim strSignature As String
If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
Exit Function
End If
'Create the Outlook session.
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo -1: On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application")
End If
'Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
'Add the To recipient(s) to the message.
For lngLoop = LBound(Split(strTo, ";")) To UBound(Split(strTo, ";"))
If Trim(Split(strTo, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strTo, ";")(lngLoop)))
objOutlookRecip.Type = 1 'olTO
End If
Next lngLoop
'Add the CC recipient(s) to the message.
For lngLoop = LBound(Split(strCC, ";")) To UBound(Split(strCC, ";"))
If Trim(Split(strCC, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strCC, ";")(lngLoop)))
objOutlookRecip.Type = 2 'olCC
End If
Next lngLoop
'Add the BCC recipient(s) to the message.
For lngLoop = LBound(Split(strBCC, ";")) To UBound(Split(strBCC, ";"))
If Trim(Split(strBCC, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strBCC, ";")(lngLoop)))
objOutlookRecip.Type = 3 'olBCC
End If
Next lngLoop
'Set the Subject, Body, and Importance of the message.
If strSubject = "" Then
strSubject = "This is an Automation test with Microsoft Outlook"
End If
.Subject = strSubject
If strMessage = "" Then
strMessage = "This is the body of the message." & vbCrLf & vbCrLf
End If
.Importance = 2 'High importance
If Not strMessage = "" Then
.Body = strMessage & vbCrLf & vbCrLf
End If
If Not rngToCopy Is Nothing Then
.HTMLBody = .Body & RangetoHTML(rngToCopy)
End If
'Add attachments to the message.
If Not strAttachmentPath = "" Then
If Len(Dir(strAttachmentPath)) <> 0 Then
Set objOutlookAttach = .Attachments.Add(strAttachmentPath)
Else
MsgBox "Unable to find the specified attachment. Sending mail anyway."
End If
End If
If blnSignature Then
'Win XP
strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\*.htm"
strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\" & Dir(strSignature)
If Dir(strSignature) = "" Then
'Win 7
strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\*.htm"
strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\" & Dir(strSignature)
End If
End If
If Dir(strSignature) <> "" Then
strSignature = GetBoiler(strSignature)
Else
strSignature = ""
End If
'MsgBox .htmlbody
If strSignature <> "" Then
.HTMLBody = .HTMLBody & strSignature
End If
'Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
'Should we display the message before sending?
If blnShowEmailBodyWithoutSending Then
.Display
Else
.Display
.Save
.Send
End If
End With
Set objOutlook = Nothing
Set objOutlookMsg = Nothing
Set objOutlookAttach = Nothing
Set objOutlookRecip = Nothing
End Function
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 strTempFile As String
Dim wbkTemp As Workbook
strTempFile = Environ$("temp") & Application.PathSeparator & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a workbook to receive the data.
rng.Copy
Set wbkTemp = Workbooks.Add(1)
With wbkTemp.Sheets(1)
With .Cells(1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
.Select
End With
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
Err.Clear: On Error GoTo 0
End With
'Publish the sheet to an .htm file.
With wbkTemp.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strTempFile, _
Sheet:=wbkTemp.Sheets(1).Name, _
Source:=wbkTemp.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the .htm file into the RangetoHTML subroutine.
RangetoHTML = GetBoiler(strTempFile)
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close wbkTemp
wbkTemp.Close savechanges:=False
'Delete the htm file.
Kill strTempFile
Set wbkTemp = Nothing
End Function
Function GetBoiler(ByVal strFile As String) As String
'May not be supported in MAC
Dim objFSO As Object
Dim objTextStream As Object
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextStream = objFSO.GetFile(strFile).OpenAsTextStream(1, -2)
GetBoiler = objTextStream.ReadAll
objTextStream.Close
Set objFSO = Nothing
Set objTextStream = Nothing
End Function
Posting Permissions
Reply With Quote
Bookmarks