Sub Mail_FichePot2()
'https://excel-downloads.com/threads/envoyer-mail-et-pj-automatique-via-bouton.20071717/
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook, Destwb As Workbook
Dim Dest As String, Corps As String
Dim TempFilePath As String, TempFileName As String
Dim RngDest As Range, DestCell As Range, rngCel As Range, strDate As String
Dim WksMail As Worksheet, wksSheet As Worksheet
Dim Trouve As Boolean
Dim OutApp As Object, OutMail As Object
Set WksMail = ThisWorkbook.Sheets("MAIL")
Set RngDest = WksMail.Range("C3:C12")
Corps = WksMail.Range("C18") & vbNewLine & vbNewLine & _
WksMail.Range("C19") & vbNewLine & _
WksMail.Range("C20") & vbNewLine & _
WksMail.Range("C21") & vbNewLine & _
WksMail.Range("C22")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
Sheets("FICHE POT").Copy
Set Destwb = ActiveWorkbook
TempFilePath = Environ$("temp") & "\"
TempFileName = "FICHE POT " & Format(Now, "dd-mmm-yy h-mm-ss") 'A' adapter
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & ".xlsx"
On Error Resume Next
For Each DestCell In RngDest
If DestCell.Value Like "*@*" Then
If Dest = "" Then
Dest = DestCell.Value
Else
Dest = Dest & ";" & DestCell.Value
End If
End If
Next
With OutMail
.to = Dest
.CC = WksMail.Range("C13").Value
.BCC = WksMail.Range("C14").Value
.Subject = WksMail.Range("C15").Value
.Body = Corps
.Attachments.Add Destwb.FullName
' .Display
.Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & ".xlsx"
Set OutMail = Nothing
Set OutApp = Nothing
strDate = ThisWorkbook.Sheets("FICHE POT").Range("C2")
If strDate <> "" Then
For Each wksSheet In ActiveWorkbook.Worksheets
For Each rngCel In wksSheet.UsedRange
If InStr(UCase(CStr(rngCel.Value)), UCase(strDate)) > 0 Then
Trouve = True
wksSheet.Activate
rngCel.Offset(0, 1).Value = "X"
End If
Next rngCel
Next wksSheet
End If
MsgBox "Message envoyé!"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
)
