Dim Rep As Integer Rep = MsgBox("Voulez-vous envoyer l'email ?", vbYesNo + vbQuestion, "Envoie Email Photobox")
If Rep = vbYes Then
répertoireAppli = "C:\Archives photobox\Dossier tempo pour email"
' Faire une copie de certaines feuilles dans un nouveau classeur
'Sheets(Array("Réception", "Cross Docking", "Way Bill Arvato")).Copy
' Faire une copie de toutes les feuilles
Sheets.Copy
'
Application.DisplayAlerts = False
' Sauvegarder le nouveau classeur sous un nom spécifique
' et le fermer
With ActiveWorkbook
.SaveAs répertoireAppli & "\Cross Docking &Way Bill PHOTOBOX du " & Format(Worksheets("Cross Docking").Range("a4"), "d\-mm\-yyyy") & ".xls"
.Close
End With
'--- Envoi par mail
Dim olapp As Object 'Outlook.Application
Sheets("Envoie Email").Select
Range("B18").Select
Set olapp = CreateObject("Outlook.Application")
Do While Not IsEmpty(ActiveCell)
Dim msg As Object 'MailItem
Set msg = olapp.CreateItem(0)
msg.To = ActiveCell.Value
msg.Subject = Range("B5").Value
msg.CC = Range("b25").Value
msg.Body = Range("B8").Value & Chr(13) & Chr(13) & Range("B9").Value & Chr(13) & Chr(13) & Range("B10").Value & Chr(13) & Chr(13) & Range("B11").Value & Chr(13) & Chr(13) & Range("B12").Value & Chr(13) & Chr(13) & Range("B15").Value & Chr(13) & Chr(13)
msg.Attachments.Add répertoireAppli & "\Cross Docking &Way Bill PHOTOBOX du " & _
Format(Worksheets("Réception").Range("w2"), "d\-mm\-yyyy") & ".xls"
msg.Send
ActiveCell.Offset(1, 0).Select
Loop
Set msg = Nothing
Set olapp = Nothing
MsgBox "Le Cross Docking a été envoyé par email avec succés ...."
Else
' Rien
End If