I am trying to loop thru a column looking for a date that is 7 days from today. When I find a date that matches, I want to send it to outlook. The problem I am having is the code I have written sends a email for every date. I want to list all dates on one email.
Below is the code I have written:
Sub Macro1()
Dim olApp As Outlook.Application, olMail As Outlook.MailItem
Dim FSObj As Scripting.FileSystemObject, TStream As Scripting.TextStream
Dim rngeSend As Range, strHTMLBody As String
Range("G2").Select
Do Until ActiveCell.Value = "stop"
If ActiveCell.Value = Date + 7 Then
Set rngeSend = ActiveCell.Offset(0, -6).Range("A1:K1")
ActiveWorkbook.PublishObjects.Add(xlSourceRange, "C:tempsht.htm", rngeSend.Parent.Name, rngeSend.Address, xlHtmlStatic).Publish True
Set FSObj = New Scripting.FileSystemObject
Set TStream = FSObj.OpenTextFile("C:tempsht.htm", ForReading)
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
With olMail
'Change email address here **********************************
.To = "myemailaddress@verizon.com"
.Subject = "Dude Pay These Bills"
strHTMLBody = TStream.ReadAll
olMail.HTMLBody = strHTMLBody & vbNewLine
'olMail.vbNewLine
ActiveCell.Offset(1, 0).Select
End With
End If
Loop
'ActiveCell.Offset(0, -6).Range("G2").Select
With olMail
.Display
'Do Until ActiveCell.Value = "stop"
' End With
' Loop
Set olMail = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True
ActiveCell.Offset(-1, 0).Select
'End If
'Loop
End With
End Sub
Below is the code I have written:
Sub Macro1()
Dim olApp As Outlook.Application, olMail As Outlook.MailItem
Dim FSObj As Scripting.FileSystemObject, TStream As Scripting.TextStream
Dim rngeSend As Range, strHTMLBody As String
Range("G2").Select
Do Until ActiveCell.Value = "stop"
If ActiveCell.Value = Date + 7 Then
Set rngeSend = ActiveCell.Offset(0, -6).Range("A1:K1")
ActiveWorkbook.PublishObjects.Add(xlSourceRange, "C:tempsht.htm", rngeSend.Parent.Name, rngeSend.Address, xlHtmlStatic).Publish True
Set FSObj = New Scripting.FileSystemObject
Set TStream = FSObj.OpenTextFile("C:tempsht.htm", ForReading)
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
With olMail
'Change email address here **********************************
.To = "myemailaddress@verizon.com"
.Subject = "Dude Pay These Bills"
strHTMLBody = TStream.ReadAll
olMail.HTMLBody = strHTMLBody & vbNewLine
'olMail.vbNewLine
ActiveCell.Offset(1, 0).Select
End With
End If
Loop
'ActiveCell.Offset(0, -6).Range("G2").Select
With olMail
.Display
'Do Until ActiveCell.Value = "stop"
' End With
' Loop
Set olMail = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True
ActiveCell.Offset(-1, 0).Select
'End If
'Loop
End With
End Sub