vba excel outlook

[Kelvim]

Boa noite

 

Eu tenho um código que envia e-mail pelo VBA EXCEL, acessando o outlook.

porém eu coloquei um código de Loop para ir alterando tando os destinatários quanto os anexo.

porém os anexos a cada loop ele acrescenta mais um.

Ele não limpa a instancia da variável.

 

Gostaria de saber como limpar a variável dos anexos.

 

Sub enviar_planilha_corpo_email()

Dim ArqAberto01, ArqAberto02, CAMINHO As String

Dim resultado As VbMsgBoxResult

ArqAberto01 = ActiveWorkbook.Name

resultado = MsgBox("Tem certeza que deseja Enviar o agendamento?", vbYesNo, "ENVIAR E-MAIL")

If resultado = vbYes Then

Application.DisplayAlerts = False

    Application.Dialogs(xlDialogOpen).Show
    ArqAberto02 = ActiveWorkbook.Name
    Windows(ArqAberto02).Activate
    CAMINHO = ActiveWorkbook.Path
    Windows(ArqAberto02).Close
    
i = 1
Do While Sheets("PAINEL").Cells(i, 15).Value <> Empty

    Application.ScreenUpdating = False
      
                Sheets("MENSAG").Select
                Sheets("MENSAG").Range("C1").Value = Sheets("PAINEL").Cells(i, 17)
                Sheets("MENSAG").Range("E1").Value = Sheets("PAINEL").Cells(i, 15)
                Sheets("PAINEL").Cells(i, 18) = CAMINHO & "\CONSOLIDADO DE ABERTURA DE OSs" & Sheets("PAINEL").Cells(i, 15) & ".xlsx"
                Range("A1", "F30").Select
                
                Selection.Copy
                
              
                ActiveWorkbook.EnvelopeVisible = True
            
            
                With ActiveSheet.MailEnvelope
                   
            '

                
                    
                    .Item.To = Sheets("PAINEL").Cells(i, 16)
                    '.Item.Attachments.Add ("" & CAMINHO & "\CONSOLIDADO DE ABERTURA DE OSs" & Sheets("PAINEL").Cells(i, 15) & ".xlsx" & "")

                    .Item.Attachments.Add ("" & Sheets("PAINEL").Cells(i, 18) & "")
                    .Item.Subject = "CONSOLIDADO DE ABERTURA DE OSs"
                    .Introduction = "CONSOLIDADO DE ABERTURA DE OSs"
                    
                    .Item.Send
                   ' .Item.Attachments.Clear
                   
                                   'Worksheet.MailEnvelope = Nothing
                End With
            
                Application.ScreenUpdating = True

    i = i + 1
    
ActiveSheet.MailEnvelope = Nothing

    Loop
 
 Else
 End If
 

End Sub

 

[Kelvim]

Boa tarde

Descobri uma solução.

Basta colocar o código a baixo do código With ActiveSheet.MailEnvelope

 

 

 

                    Do Until .Item.attachments.Count = 0
                    .Item.attachments(1).Delete
                    Loop