I need to send email from excel to individual persons based on the sheet names. If sheet1 name is raju, it must be sent as an attachment to [email protected], sheet2 name is babu, it must be sent as an attachment to [email protected]
Im trying to write a code but stuck in one line where we specify recipient name. attaching the code below.
Sub Mail_Every_Worksheet()
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xFileExt As String
Dim xFileFormatNum As Long
Dim xTempFilePath As String
Dim xFileName As String
Dim xOlApp As Object
Dim xMailObj As Object
Dim subj As String
Dim body As String
subj = InputBox("enter subject")
body = InputBox("enter body")
Dim CurrDate As String
CurrDate = Format(Date, "MM-DD-YY")
On Error Resume Next
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
xTempFilePath = Environ$("temp") & "\"
If Val(Application.Version) < 12 Then
xFileExt = ".xls": xFileFormatNum = -4143
Else
xFileExt = ".xlsm": xFileFormatNum = 52
End If
Set xOlApp = CreateObject("Outlook.Application")
For Each xWs In ThisWorkbook.Worksheets
If xWs.Name <> "Sheet1" Then
xWs.Copy
Set xWb = ActiveWorkbook
xFileName = xWs.Name & " " & CurrDate
Set xMailObj = xOlApp.CreateItem(0)
With xWb
.SaveAs xTempFilePath & xFileName & xFileExt, FileFormat:=xFileFormatNum
With xMailObj
'specify the CC, BCC, Subject, Body below
.To = xWs.Sheets(i).Name & "@gmail.com"
.CC = ""
.BCC = ""
.Subject = subj
.body = body
.Attachments.Add xWb.FullName
.Display
End With
.Close SaveChanges:=False
End With
Set xMailObj = Nothing
Kill xTempFilePath & xFileName & xFileExt
End If
Next
Set xOlApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
the only error i get is on this line
.To = xWs.Sheets(i).Name & "@gmail.com"
can someone help me how to fix this error Thanks in advance.
CodePudding user response:
There is no need to use the Sheets
property to get the Worksheet.Name
property value. You already deal with a Worksheet instance in the loop, so you just need to retrieve the Name
property.
Dim xWs As Worksheet
...
For Each xWs In ThisWorkbook.Worksheets
...
.To = xWs.Name & "@gmail.com"
Be aware, the recommended way of setting recipients for the email is to using the Recipients.Add
method which creates a new recipient in the Recipients
collection. Then you need to call the Resolve
method which attempts to resolve a Recipient
object against the Address Book. For example:
Set myRecipient = MyItem.Recipients.Add("Eugene Astafiev")
myRecipient.Resolve
If myRecipient.Resolved Then
myItem.Subject = "Test task"
myItem.Display
End If
Read more about that in the article which I wrote for the technical blog - How To: Fill TO,CC and BCC fields in Outlook programmatically.