Hi I am using the below code to send multiple emails based on different cases. (Email addressess and other information are stored in a worksheet) The code works fine however I have 20 different cases (example below only shows two). Putting the outlook application code within each case seems cumbersome.
Is there a method to perform the email against each case without having to express the outlook code within each case?
I have searched using For Each Case without any luck. Help is greatly appreciated.
Sub RequestUpdates()
Dim olApp As Outlook.Application
Dim olMail As Outlook.MailItem
Dim blRunning As Boolean
Dim email As String
Dim fname As String
Dim fllink As String
Dim cpname As String
Dim v As Integer
Dim y As Integer
Dim rng As Range
Dim rdate As Date
Dim signature As String
v = Sheets("Contributors").Range("A" & Rows.Count).End(xlUp).Row
Set rng = Sheets("Contributors").Range("A1")
rdate = Sheets("Contributors").Range("A1").Value
For y = 0 To v
Select Case rng.Offset(1 + y, 0).Value
Case "PCR"
email = Sheets("Contributors").Range("E4").Value
fname = Sheets("Contributors").Range("D4").Value
fllink = Sheets("Contributors").Range("F4").Value
cpname = Sheets("Contributors").Range("B4").Value
'get application
blRunning = True
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
Set olApp = New Outlook.Application
blRunning = False
End If
On Error GoTo 0
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.Display
End With
signature = olMail.HTMLBody
With olMail
'Specify the email subject
.Subject = "test " & rdate
'Specify who it should be sent to
'Repeat this line to add further recipients
.Recipients.Add email
'specify the file to attach
'repeat this line to add further attachments
'.Attachments.Add "LinktoAttachment"
'specify the text to appear in the email
.HTMLBody = "<p>Hi " & fname & ",</p>" & _
"<P>Please follow the link below to update the " & cpname & " test" _
& "For month ending " & rdate & ".</p>" & _
"<P> </br> </p>" & _
fllink & _
"<P> </br> </p>" & _
"<p>If you face issues with file access please contact me directly.</p>" & _
"<P>Note: xxxxx.</p>" & _
signature
'Choose which of the following 2 lines to have commented out
.Display 'This will display the message for you to check and send yourself
'.Send ' This will send the message straight away
End With
Case "NFG"
email = Sheets("Contributors").Range("E6").Value
fname = Sheets("Contributors").Range("D6").Value
fllink = Sheets("Contributors").Range("F6").Value
cpname = Sheets("Contributors").Range("B6").Value
'get application
blRunning = True
Set olApp = GetObject(, "Outlook.Application")
If olApp Is Nothing Then
Set olApp = New Outlook.Application
blRunning = False
End If
On Error GoTo 0
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.Display
End With
signature = olMail.HTMLBody
With olMail
'Specify the email subject
.Subject = "Test" & rdate
'Specify who it should be sent to
'Repeat this line to add further recipients
.Recipients.Add email
'specify the file to attach
'repeat this line to add further attachments
'.Attachments.Add "LinktoAttachment"
'specify the text to appear in the email
.HTMLBody = "<p>Hi " & fname & ",</p>" & _
"<P>Please follow the link below to update the " & cpname & " component Test" _
& "For month ending " & rdate & ".</p>" & _
"<P> </br> </p>" & _
fllink & _
"<P> </br> </p>" & _
"<p>If you face issues with file access please contact me directly.</p>" & _
"<P>Note: Test.</p>" & _
signature
'Choose which of the following 2 lines to have commented out
.Display 'This will display the message for you to check and send yourself
'.Send ' This will send the message straight away
End With
End Select
Next
End Sub
