Send multiple emails using one command button

[elsuji]

Dear Team,


I am trying to send two separate emails by clicking one command button using the below code.


Option Explicit
Sub EmailTrainingValue()

'Variable declaration
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String
Dim MailSub As String
Dim MailTxt As String
Dim MailTo As String
Dim MailSub1 As String
Dim MailTxt1 As String
Dim Mail1To1 As String
Dim lRow As Long
Dim lCol As Long
Dim MR As Range, Cell As Range
Dim mySheet As String
Dim TempFilePath As String
Dim TempFileName As String
Dim FileFullPath As String


'-----------------------Creatte Email List---------------
Dim sh As Worksheet, rng As Range, c As Range, s As String
Set sh = Sheets("Data")
s = ""
With sh
Set rng = .Range("O9") '.SpecialCells(xlCellTypeConstants, 23)
For Each c In rng.Cells
s = s & c & ";"
Next c
End With
s = Left(s, Len(s) - 1)
'--------------------End Email List-----------------------
'************************************************* ********
'Set email details; Comment out if not required
MailTo = s
Const MailCC = "some2@someone.com"
Const MailBCC = "some3@someone.com"
MailSub = " Oil Service for your " & mySheet & " Machine"
MailTxt = "Dear Sir," & vbLf & vbLf & "Please fine here with attached Training conducted details on for "
'************************************************* ********

'************************************************* ********
'Set email details; Comment out if not required
Mail1To1 = "spares.bangalore@gmail.com"
'Const MailCC = "some2@someone.com"
'Const MailBCC = "some3@someone.com"
MailSub1 = " Quotation required for oil service"
MailTxt1 = "Dear Team," & vbLf & vbLf & "Please send quotation for the attachment "
'************************************************* ********

'Turns off screen updating
Application.ScreenUpdating = False

'Makes a copy of the active sheet and save it to a temporary file
Dim wks As Worksheet

mySheet = Worksheets("Data").Cells(9, 2).Value
TempFilePath = Environ$("temp") & "\"
TempFileName = mySheet & "Service details.pdf"
FileFullPath = TempFilePath & TempFileName
lCol = Cells(9, Columns.Count).End(xlToLeft).Column
Set MR = Range("C9:N9" & lCol)
For Each Cell In MR
If Cell.Value > 25 And Cell.Value <= 50 Then
'Cell.Interior.Color = VBA.ColorConstants.vbGreen
Worksheets(mySheet).Range("B2:F24").ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
ElseIf Cell.Value > 400 And Cell.Value <= 500 Then
'Cell.Interior.Color = VBA.ColorConstants.vbGreen
Worksheets(mySheet).Range("B26:F65").ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
ElseIf Cell.Value > 900 And Cell.Value <= 1000 Then
'Cell.Interior.Color = VBA.ColorConstants.vbGreen
Worksheets(mySheet).Range("B67:F115").ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=FileFullPath, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
On Error GoTo 0
Next Cell



'Creates and shows the outlook mail item
Set oApp = CreateObject("Outlook.Application")
Set oMail = oApp.CreateItem(0)
'1st email
With oMail
.To = MailTo
.Subject = MailSub
.Body = MailTxt
.Attachments.Add FileFullPath
.Display
End With

'2nd email
With oMail
.To = Mail1To1
.Subject = MailSub1
.Body = MailTxt1
.Attachments.Add FileFullPath
.Display
End With
'Restores screen updating and release Outlook
Application.ScreenUpdating = True
Set oMail = Nothing
Set oApp = Nothing
End Sub





Once i click the command button using the above code only one email is working.


Can any one please help me for my above query.


I am attaching my file here for your reference.