Option Explicit
Dim i As Long, cel As Range, Chemin As String, Nom As String
Dim CCMail, BCCMail, AdressMail, CopieC, Strcc
Sub Envoi_Mail()
Dim olApp As Outlook.Application
Dim olMail As MailItem
With Sheets(1)
CCMail = .Range("AO11")
BCCMail = .Range("AO5") & ";" & .Range("al5")
End With
Chemin = Environ$("temp") & "\"
Nom = "Courrier Outlook" & ".xlsm"
Sheets(2).Activate
With ActiveSheet
.Copy
.SaveAs Filename:=Chemin & Nom, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWorkbook.Close True
End With
On Error GoTo ErrHandler
For Each cel In Sheets(1).Range([AH2], Sheets(1).[AH65536].End(xlUp))
Strcc = Strcc & cel.Value & ";"
Next cel
CopieC = Split(Strcc, ";")
For i = 0 To UBound(CopieC) - 1
If CopieC(i) = AdressMail Then
Exit For
Else
AdressMail = AdressMail & CopieC(i) & ";"
End If
Next i
ErrHandler:
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.To = Mid(AdressMail, 1, Len(AdressMail) - 1)
.CC = CCMail
.BCC = BCCMail
.Subject = ""
.HTMLBody = ""
.Attachments.Add Chemin & Nom
.Display
End With
Set olMail = Nothing
Set olApp = Nothing
Kill Chemin & Nom
End Sub