Loop thru a column looking for certian dates, then outlook

[dude0216]

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

 

[anthonya2369]

The problem is your loop. You are telling it to send separate emails and then is goes to next cell and does the same.

On the loop just do something like this

strbody = ""
do until activecell.value = "stop"
     if activecell.value = date + 7 then
          strBody = strbody & activecell.value & vbnewline
     end if
ActiveCell.Offset(1, 0).Select 
Loop

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" 
.body = strbody 
End With

 

[dude0216]

Code works, but email is wrong

Anthony,

This looping code works, but when I receive the email all it has in the body is true. I would like to copy the range A1:K1 and then paste this into the body of the email if the date in column G is equal to today plus 7 days. I have updtaed the code and it tis pasted below.
Thanks

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
strbody = ""
Do Until ActiveCell.Value = "stop"
If ActiveCell.Value = Date + 7 Then
strbody = strbody & ActiveCell.Offset(0, -6).Range("A1:K1").Select & vbNewLine
ActiveCell.Offset(0, 6).Select
End If
ActiveCell.Offset(1, 0).Select
Loop
ActiveWorkbook.PublishObjects.Add(xlSourceRange, "C:tempsht.htm", strbody.Parent.Name, strbody.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.net"
.Subject = "Dude Pay These Bills"
.Body = strbody


End With

Set olMail = Nothing

Set olApp = Nothing
Application.ScreenUpdating = True


ActiveCell.Offset(-1, 0).Select

End Sub

 

[anthonya2369]

Change this line:

strbody = strbody & ActiveCell.Offset(0, -6).Range("A1:K1").Select & vbNewLine

to:

tmpBody = activecell.offset(0,-6).value & "  " & activecell.offset(0,-5).value & "  " & activecell.offset(0,-4).value & "  " & activecell.offset(0,-3).value & "  " & activecell.offset(0,-2).value & "  " & activecell.offset(0,-1).value & "  " & activecell.value & "  " & activecell.offset(0,1).value & "  " & activecell.offset(0,2).value & "  " & activecell.offset(0,3).value & "  " & activecell.offset(0,4).value 
strBody = strBody & tmpBody & vbnewline

 

[dude0216]

Additional Problem

Anthony,

That seems to work, but the following line produces the folowing error.

Run-time error 424 Object Required

ActiveWorkbook.PublishObjects.Add(4, strTempFilePath, "C:tempsht.htm", tmpbody.Parent.Name, tmpbody.Address).Publish True

Thanks,

 

[anthonya2369]

skip that line (comment it out for now)

You need to add a .display or .send with your "with olMail" or it will do nothing with the email message.

 

[dude0216]

Perfect

Anthony,

This worked perfectly, thanks for your help.


Paul

 

[dude0216]

One more question

Anthony,

I added more code, and everything is working with the exception of the pasting to email. When the program pastes to email noting is there. Would it be possible for you to look at the code below and explain why this is not working?

Sub Macro1()

Dim olApp As Outlook.Application, olMail As Outlook.MailItem
Dim FSObj As Scripting.FileSystemObject, TStream As Scripting.TextStream
Dim strHTMLBody As String
Sheets("Sheet1").Select
Range("J2").Select
Do Until ActiveCell.Value = 0
If ActiveCell > 0 Then ActiveCell.EntireRow.Cut
Sheets("Sheet2").Select
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Rows("1:1").Select
Cells.Select
Selection.Columns.AutoFit
Sheets("Sheet1").Select
ActiveCell.Offset(1, 0).Select
Loop
Range("G2").Select
strbody = ""
Do Until ActiveCell.Value = "stop"
If ActiveCell.Value = Date + 7 Then
tmpbody = ActiveCell.Offset(0, -6).Value & " " & ActiveCell.Offset(0, -5).Value & " " & ActiveCell.Offset(0, -4).Value & " " & ActiveCell.Offset(0, -3).Value & " " & ActiveCell.Offset(0, -2).Value & " " & ActiveCell.Offset(0, -1).Value & " " & ActiveCell.Value & " " & ActiveCell.Offset(0, 1).Value & " " & ActiveCell.Offset(0, 2).Value & " " & ActiveCell.Offset(0, 3).Value & " " & ActiveCell.Offset(0, 4).Value
strbody = strbody & tmpbody & vbNewLine
End If
ActiveCell.Offset(1, 0).Select
Loop


Set FSObj = New Scripting.FileSystemObject


Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
With olMail
'Change email address here **********************************
.To = "myemailaddress@verizon.net"
.Subject = "Dude Pay These Bills"
.Body = strbody
.Display
End With
Set olMail = Nothing
Set olApp = Nothing
Application.ScreenUpdating = True
ActiveCell.Offset(-1, 0).Select
End Sub

 

[anthonya2369]

Could it be possible that there are no Bills due on the day you ran it? Chagne the date on your pc to a day that you know there are bills and see if it pulls anything in there. You can set up a if statement before it creates the email and if strBody = "" then it messages you saying No bills due right now. Right now the statement looks for any values = to Date + 7. If you want it greater than or equal to 7 then change the line:

if activecell.value = date + 7 then

to:

if activecell.value >= date + 7 then

 

[dude0216]

Works Fine

Anthony,

The code works correctly, thanks for you help.