Sub envoi_Feuille()
répertoireAppli = ActiveWorkbook.Path
Sheets("BEV").Copy
ActiveSheet.Unprotect Password:="PP"
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("F:F").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
ActiveSheet.Shapes("Button 1").Select
Selection.Delete
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs répertoireAppli & "\BEV.xls"
ActiveWindow.Close
'--- Envoi par mail
Dim olapp As Outlook.Application
Sheets("BEV").Select
Range("F11").Select
Do While Not IsEmpty(ActiveCell)
Dim msg As MailItem
Set olapp = New Outlook.Application
Set msg = olapp.CreateItem(olMailItem)
msg.To = ActiveCell.Value
msg.Subject = Range("F2").Value
msg.Body = Range("F5").Value & Chr(13) & Chr(13) & Range("F8").Value & Chr(13) & Chr(13)
msg.Attachments.Add Source:=répertoireAppli & "\BEV.xls"
msg.Send
ActiveCell.Offset(1, 0).Select
Loop
End Sub