Email with Glitches

[KentC]

I’m using the following code to send email. It is able to send email and attachment. But, there are glitches:

1. The “To” field is not populating.
2. The “cc’ field is populating with information that is supposed to populate in the “To”
3. The “cc” field is not populating with the “cc” values i.e. a@b.com

Please help.

Sub Mail()

Dim subject As String, text As String, Recipient As String
Dim ccRecipient(35) As Variant
Dim aAttach(35) As Variant
Dim range1 As Range
Dim day, time, ans As String
macro = "Email1.xls"

Recipient = Workbooks(macro).Sheets("abcf"). _
Range("a").Offset(b, 1)

text1 = "Hi ","

text2 = vbNewLine & vbNewLine & "Please find attached..”

text3 = vbNewLine & vbNewLine & vbNewLine & "Regards,"

cc = 1
ccRecipient(cc) = "A@b.com"
cc = 2
ccRecipient(cc) = "d@e.com"

text = text1 & text2 & text3
'MsgBox (subject)
'MsgBox (text)
Call SendOutlookMail(subject, aAttach(), Recipient, ccRecipient(), text, True)
For i = 0 To 39
aAttach(file_count) = Empty
ccRecipient(cc) = Empty
Next i
file_count = 0
cc = 0
f = f + 1
Loop

End Sub


Sub SendOutlookMail(subject As String, attachment As Variant, Recipient As Variant, ccRecipient As Variant, BodyText As String)

'Set up the objects required for Automation into Outlook.
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.attachment

On Error GoTo SendOutlookMail_Err

'Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

'Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

With objOutlookMsg
'Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(Recipient)
objOutlookRecip.Type = olTo

'Add the CC recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(ccRecipient)
objOutlookRecip.Type = olCC

'Set the Subject, Body, and Importance of the message.
.subject = subject
.Body = BodyText & vbCrLf & vbCrLf
'.Importance = olImportanceHigh 'High importance

'Add attachments to the message.
For i = 1 To UBound(attachment)
If Not IsMissing(attachment(i)) Then
Set objOutlookAttach = .Attachments.Add(attachment(i))
End If
Next i

'Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Send

End With

'Clean Up
Set objOutlookMsg = Nothing
Set objOutlook = Nothing

SendOutlookMail_Err:
Resume Next

End Sub

[p45cal]

try (I've tried to highlight changes in red, though not all of them show):Sub Mail()
Dim subject As String, text As String, Recipient As String
Dim ccRecipient(35) As Variant
Dim aAttach(35) As Variant
Dim range1 As Range
Dim day, time, ans As String
macro = "Email1.xls"

Recipient = Workbooks(macro).Sheets("abcf").Range("a").Offset(b, 1)
text1 = "Hi "
text2 = vbNewLine & vbNewLine & "Please find attached.."
text3 = vbNewLine & vbNewLine & vbNewLine & "Regards,"

cc = 1
ccRecipient(cc) = "A@b.com"
cc = 2
ccRecipient(cc) = "d@e.com"

text = text1 & text2 & text3
'MsgBox (subject)
'MsgBox (text)
Call SendOutlookMail(subject, aAttach(), Recipient, ccRecipient(), text) ', True)
Erase aAttach '(file_count) = Empty
Erase ccRecipient '(cc) = Empty
file_count = 0
cc = 0
f = f + 1
'Loop
End Sub
Sub SendOutlookMail(subject As String, attachment As Variant, Recipient As Variant, ccRecipient As Variant, BodyText As String)
'Set up the objects required for Automation into Outlook.
'changed the following 4 lines so that you don't have to have a reference to the Outlook Object library in the vbe:
Dim objOutlook As Object 'Outlook.Application
Dim objOutlookMsg As Object 'Outlook.MailItem
Dim objOutlookRecip As Object 'Outlook.Recipient
Dim objOutlookAttach As Object 'Outlook.attachment

On Error GoTo SendOutlookMail_Err

'Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

'Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0) ' 0=olMailItem
With objOutlookMsg
'Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(Recipient)
objOutlookRecip.Type = 1 'olTo=1 'olBCC = 3

'Add the CC recipient(s) to the message.
For Each rcpnt In ccRecipient
If Not IsEmpty(rcpnt) Then
Set objOutlookRecip = .Recipients.Add(rcpnt)
objOutlookRecip.Type = 2 'olCC
End If
Next rcpnt
'Set the Subject, Body, and Importance of the message.
.subject = subject
.Body = BodyText & vbCrLf & vbCrLf
'.Importance = 2 'olImportanceHigh = 2 'High importance

'Add attachments to the message.
For i = 0 To UBound(attachment)
If Not IsEmpty(attachment(i)) Then
Set objOutlookAttach = .Attachments.Add(attachment(i))
End If
Next i

'Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.display
End If
Next
.Send
End With

'Clean Up
Set objOutlookMsg = Nothing
Set objOutlook = Nothing

SendOutlookMail_Err:
Resume Next
End Sub
Tested and working.

I nearly didn't respond at all to this because as I was Googling for solutions I found that you'd posted this same question elsewhere; 'What luck' I thought, 'I can check first to see if there's been a sucessful resolution to this and I won't need to do any work' However, I saw that you hadn't had a satisfactory response at those places so I did do some work - but what if I'd done the work, and later discovered you'd already had a resolution elsewhere? I'd be mightily piqued (and probably make a mental note never to respond to your posts in the future - because I'd assume cross-posting as a given, and would not want to bother searching the internet to see if you had done so).
An easy solution to this is to provide links to where you've cross-posted so that it makes it relatively easy for potential responders to check whether you're problem has already been resolved elsewhere. High horse now dismounted.

[KentC]

Hi,

Sorry for taking time to get back to you. Thank you for taking your time for looking into the code. All I can say is that the code is working awesome and I'm very grateful for that. I wanted to say thank you to you via PM but I needed at least 10 posts to do so.

Best wishes to you and continue the great work!:thumb