Duplicate Attachments when sending email using VBA

[vtobias]

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 attachment and sent it through email.
The file is aimed to be sent to different areas and recipients, so at times I have to select a filter and send the file again using the VBA code that I have, but what it does is it attached the file again, resulting to having 2 attachments (same file)

Here's the macro I use.

Sub Email_CurrentWorkBook()

    Dim OlApp As Object
    Dim NewMail As Object

    Set OlApp = CreateObject("Outlook.Application")
    Set NewMail = OlApp.CreateItem(0)


    On Error Resume Next
  Sheets("SELECTOR").Select
    ActiveSheet.Range("AK1:AX128").Select
    ActiveWorkbook.EnvelopeVisible = True
    With ActiveSheet.MailEnvelope
      .Item.sentOnBehalfOfName = Range("Q2").Value
      .Item.To = Range("Q3").Value
      .Item.Cc = Range("Q4").Value
      .Item.Subject = Range("Q5").Value
    .Item.Attachments.Add ActiveWorkbook.FullName
    .Item.Send
    End With
    On Error GoTo 0

    Set NewMail = Nothing
    Set OlApp = Nothing
End Sub

 

[daverunt]

See if this works. Place before .Item.Attachments.Add

    .Item.Subject = Range("Q5").Value
            
    Set attch = .Item.Attachments
 
    While attch.Count > 0
        attch.Remove 1
    Wend
   
    .Item.Attachments.Add ActiveWorkbook.FullName

 

[Evelyn12]

See if this works. Place before .Item.Attachments.Add

    .Item.Subject = Range("Q5").Value
           
    Set attch = .Item.Attachments
 
    While attch.Count > 0
        attch.Remove 1
    Wend
  
    .Item.Attachments.Add ActiveWorkbook.FullName

I had the same issue and this answer helped a lot! Thanks