Send Automatic Reminder Mails Row By Row Based On Status

[amar.kshirsagar]

Help Me
Hello Gurus

I was added macro with the base on rondebruin, but it is not fit to me. I also checked post related to me @ excelforum, but not getting perfect solution.
I am not familiar with the tools, macros & VB. If anyone helps me to solve the situation, it will help me a lot.

Scenario

[Excel Fox]

Which email client are you using?

[amar.kshirsagar]

email client is outlook 2010.

Thanks for your prompt reply, and sorry for forgot to update email client.:)

[Excel Fox]

Here's the code. I've also attached the sample workbook.



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


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

[amar.kshirsagar]

Hi,

Regret to not answering instantly. But after getting your code, my first reaction is "AWESOME".

It's AWESOME and working fabulous. What efforts you put to create the code it's really helping me a lot.

I appreciate the knowledge you have in excel & MACROS

Thanks Thanks Thanks


Regards

Amar K :):)