VBA sending emails through outlook problem.

[gd6noob]

Hi guys,

So I have weird issue.
The code I have works and sends to all the Recipients, picks up word doc as body and attaches files. But for some reason, for some people, it sends multiple attachments and for some, only 1 attachment.

Sub SendMailNoTemplate()

Dim objOutlook As Object, objMail As Object, OutApp As Object, OutMail As Object
Dim ws As Worksheet
Dim cell As Range, FileCell As Range, rng As Range
Dim signature As String
Dim LstRow As Long
Dim oAccount As Outlook.Account
Dim wd As Word.Application
Dim doc As Word.Document


Set objOutlook = CreateObject("Outlook.Application")
Set ws = Sheets("Email")
Set wd = CreateObject("Word.Application")
    wd.Visible = True
Set doc = wd.Documents.Open(Filename:="C:\Users\leonge\Desktop\Email\" & Sheets("Dashboard").Range("G27"), ReadOnly:=True)
    'Copy the open document
    doc.Content.Copy
    doc.Close
    
LstRow = ws.Cells(Rows.Count, 1).End(xlUp).Row

For Each oAccount In Outlook.Application.Session.Accounts

If oAccount = Sheets("Dashboard").Range("G17") Then

    For Each cell In ws.Range("A2:A" & LstRow)
    
        Set objMail = objOutlook.CreateItem(0)
        signature = objMail.Body
            With objMail
            .To = ws.Cells(cell.Row, 1).Value
            .CC = ws.Cells(cell.Row, 2).Value
            .Subject = ws.Cells(cell.Row, 3).Value
'            .Body = rngBody.Value   'commented out to send DOC as body
            .BodyFormat = olFormatRichText
                Set Editor = .GetInspector.WordEditor
                Editor.Content.Paste
                .Display
           
            Set rng = ws.Cells(cell.Row, 1).Range("F1")
            
                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell.Value) <> "" Then
                           If Dir(FileCell.Value) <> "" Then
                                .Attachments.Add FileCell.Value
                           End If
                    End If
                Next FileCell
              
            Set .SendUsingAccount = oAccount
                .Send
            End With
    
        Set objMail = Nothing
    Next cell
    Else
End If

Next

Set wd = Nothing
Set doc = Nothing
Set ws = Nothing
Set objOutlook = Nothing
Set objMail = Nothing
Set wd = Nothing
Set doc = Nothing
Set ws = Nothing
MsgBox "Emails sent"

End Sub

Emailold.xlsb
	A	B	C	D	E	F
1	To	CC	Subject	Name	Body	Attachment
2	test@outlook.com		test			C:\Users\leonge\Desktop\Email\Attachments\test.pdf
3	test@gmail.com		Essential Work Letter - For Ontario - Stay at home order			C:\Users\leonge\Desktop\Email\Attachments\test.pdf
Email

So to sum up;
1 - Some Recipients receive more then 1 attachment, if I have 10 Recipients, then a few would receive 10 attachments. if I have 20 Recipients, then a few would receive 20 attachments.
2 - how to hide outlook from showing the email being created?
3 - is there more efficient way to code?

 

[daverunt]

Sounds like it is adding an attachment to the same object each time you loop. So each new mail would get previous attachments + 1

You created the objMail inside the loop. Try setting it to Nothing before exiting the loop and creating a new objMail.

End If
Set objMail = Nothing
Next

Set wd = Nothing
Set doc = Nothing
Set ws = Nothing
Set objOutlook = Nothing
Set wd = Nothing
Set doc = Nothing
Set ws = Nothing
MsgBox "Emails sent"

End Sub

There's always the option to check if there are attachments and remove them before adding the one you want.

Duplicate Attachments when sending email using VBA

Hi everyone, First time posting here. I am in no means an expert with VBA, I usually go through google and try to mix and match codes. I'm stumped with the current project I'm working on. What I'm trying to do is have a vba code wherein it will send the current workbook I'm working on as an...

www.mrexcel.com

As you are copying/pasting from a Word doc to the email body it needs to display the mail to do the pasting.

 

[gd6noob]

I tried putting the "Set objMail = Nothing" before the end of loop and still the same issue...

 

[GWteB]

I think the following line of code is not giving you the result that you are expecting.
Would recommend to add a debug line so the immediate window shows you what is going on.

    For Each FileCell In Rng.SpecialCells(xlCellTypeConstants)
Debug.Print FileCell.Address