PDA

View Full Version : Using Loops do create emails from Excel



big45feet
01-18-2015, 05:07 PM
Hi all,
I am a newbie to VBA and am having diffculty getting my code to work for more than one email addresss.
What I am trying ACHIEVE is send emails to those with the reservation date (column K) highligthed in red which will have an associated drawing number and date in the body of the email. I have managed to create this for 1st recipient but i'm having trouble looping through the contacts and sending everyone else with there date highligthed in red an individual email with there specialsed drawing number and reservation date.
Here is what i have so far, i have also included a screenshot of the spreadsheet

Sub SendReminderMail()
Dim OutLookApp As Outlook.Application
Dim OutLookMailItem As Outlook.MailItem
Dim C As Integer
Dim C2 As Integer
Dim MailDest As String
Dim DrawNum As String

''Allow access to OutLook
Set OutLookApp = CreateObject("OutLook.Application")
Set OutLookMailItem = OutLookApp.CreateItem(0)

On Error GoTo cleanup

DrawNum = ""
For C2 = 1 To WorksheetFunction.CountA(Columns(11)) 'counter increments as it passes through the rows of Column 11 or K = reservation expiry
If DrawNum = "" And Cells(C2, 11).Interior.ColorIndex = 3 Then 'the drawing numbers with there expiry dates highligthed in red will be collected
DrawNum = Cells(C2, 11).Offset(0, -9).Value
ElseIf DrawNum <> "" And Cells(C2, 11).Interior.ColorIndex = 3 Then
DrawNum = "Your reservation for Electrical Drawing Number: " & Cells(C2, 11).Offset(0, -9).Value & " expires on the " & Cells(C2, 11).Value & "."
End If

MailDest = ""
For C = 1 To WorksheetFunction.CountA(Columns(11)) 'counter increments as it passes through the rows of Column 11 or K = reservation expiry
If MailDest = "" And Cells(C, 11).Interior.ColorIndex = 3 Then 'the emails with there expiry date highligthed in red will be collected
MailDest = Cells(C, 11).Offset(0, 1).Value 'And DrawNum = Cells(C, 11).Offset(0, -9).Value
ElseIf MailDest <> "" And Cells(C, 11).Interior.ColorIndex = 3 Then
MailDest = Cells(C, 11).Offset(0, 1).Value
End If

Next C
Next C2


With OutLookMailItem
.To = MailDest
.Subject = "Electrical Drawing Reminder"
.Body = DrawNum
.Display
End With

On Error Resume Next
Set OutLookApp = Nothing
Set OutLookMailItem = Nothing

On Error GoTo 0

''once email is sent OutLookMailItem and OutLookApp are intialised
''error blocker, blocks irrelevant or neigible error messages from appearing
cleanup:
Set OutLookApp = Nothing
Application.ScreenUpdating = True
End Sub

Bob Phillips
01-19-2015, 01:31 AM
Sub SendReminderMail()
Dim OutLookApp As Outlook.Application
Dim OutLookMailItem As Outlook.MailItem
Dim C As Integer
Dim C2 As Integer
Dim MailDest As String
Dim DrawNum As String

''Allow access to OutLook
Set OutLookApp = CreateObject("OutLook.Application")
Set OutLookMailItem = OutLookApp.CreateItem(0)

On Error GoTo cleanup

DrawNum = "": MailDest = ""
For C2 = 1 To WorksheetFunction.CountA(Columns(11)) 'counter increments as it passes through the rows of Column 11 or K = reservation expiry

If Cells(C2, 11).Interior.ColorIndex = 3 Then 'the drawing numbers with there expiry dates highligthed in red will be collected

If DrawNum = "" Then

DrawNum = Cells(C2, 11).Offset(0, -9).Value
ElseIf DrawNum <> "" And Cells(C2, 11).Interior.ColorIndex = 3 Then

DrawNum = "Your reservation for Electrical Drawing Number: " & Cells(C2, 11).Offset(0, -9).Value & " expires on the " & Cells(C2, 11).Value & "."
End If

MailDest = Cells(C2, 11).Offset(0, 1).Value

With OutLookMailItem

.To = MailDest
.Subject = "Electrical Drawing Reminder"
.Body = DrawNum
.Display
End With
End If
Next C2

On Error Resume Next
Set OutLookApp = Nothing
Set OutLookMailItem = Nothing
On Error GoTo 0

''once email is sent OutLookMailItem and OutLookApp are intialised
''error blocker, blocks irrelevant or neigible error messages from appearing
cleanup:
Set OutLookApp = Nothing
Set OutLookMailItem = Nothing
Application.ScreenUpdating = True
End Sub

big45feet
01-19-2015, 01:34 PM
Thank you Xld. I have implemented your changes but when i run the code and change .display to .send only the 1st email address is emailed.

Bob Phillips
01-20-2015, 02:23 AM
When you have .Display, does it show all of the workbooks to be emailed, or is that just one as well?

Post the workbook and let's see it for ourselves.

big45feet
01-20-2015, 02:20 PM
:)

big45feet
01-20-2015, 02:22 PM
At the moment the code runs for one worksheet for .display or .send, I have placed buttons on each worksheet Linking to the module containing this code.
I have uploaded the excel file

big45feet
01-20-2015, 02:26 PM
the code is located in module 22, i've made a few changes but it still gives me the same results as the code you posted xld. thanks for looking into this for me

Bob Phillips
01-21-2015, 02:40 AM
I can only see one worksheet with one red cell, so you would expect just one email. Even then, the red is in column 11 and you are now testing column 10.

I change the code to column 11, added another red, and got both output.

big45feet
01-21-2015, 02:50 PM
sorry I had 2 copies of the code one in module 1 and the other in module 22 coz some of the worksheets have the reservation expiry column in column 10

big45feet
01-26-2015, 12:22 AM
I don't no y it isn't working for me but I still only get the 1st email reminder being sent and the rest are ignored. Did u change any settings xld

gmayor
01-26-2015, 04:44 AM
Having looked at your worksheet and the code, the reason you only get one message (for the last red item) is that you create the message outside the loop. You need to create the messages inside the loop.

I didn't understand what you were trying to achieve with the conditional DrawNum variable, so it would appear you can simplify that.

I didn't like the use of C2 as a variable name so I have changed it to something more meaningful.

The screen shot shows that the first row with data is 5, so start the loop there.

I prefer to address the cells directly rather than use offset (as it is easier to follow), but offset would work well provided you have the correct column references.

I have changed to late binding to Outlook (you won't need a reference to Outlook in the project), and if Outlook is already open it is faster to use the open instance of Outlook than to create one.



Option Explicit

Sub SendReminderMail()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iRow As Long
Dim MailDest As String
Dim DrawNum As String
Dim LastRow As Long
Dim xlSheet As Worksheet
Dim bStarted As Boolean

Set xlSheet = ActiveSheet
''Allow access to OutLook
On Error Resume Next
'Get Outlook if it's running
Set OutLookApp = GetObject(, "Outlook.Application")

'Outlook wasn't running, start it from code
If Err <> 0 Then
Set OutLookApp = CreateObject("Outlook.Application")
bStarted = True
End If
On Error GoTo Cleanup

With xlSheet
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For iRow = 5 To LastRow
If .Cells(iRow, 11).Interior.ColorIndex = 3 Then
DrawNum = "Your reservation for Electrical Drawing Number: " & _
.Cells(iRow, 2).Value & " expires on the " & _
.Cells(iRow, 11).Value & "."

MailDest = .Cells(iRow, 12).Value
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
.BodyFormat = 1
.To = MailDest
.Subject = "Electrical Drawing Reminder"
.body = DrawNum
.Display 'Change to .Send after testing
End With
End If
DoEvents
Next iRow
End With

Cleanup:
If bStarted Then OutLookApp.Quit
Set OutLookApp = Nothing
Set OutLookMailItem = Nothing
Application.ScreenUpdating = True
End Sub

big45feet
01-26-2015, 01:38 PM
thank you so much gmayor the code works perfectly :)