VBA - Exporter feuille Excel (Pour envoi Mail)
Bonjour,
j'ai reproduit un programme permettant d'exporter une feuille au format Pdf de l'envoyer en pièce jointe par mail (puis de supprimer ce fichier).
Le code fonctionne mais je voudrai en faire une variante ou le fichier exporté ne serai plus un fichier Pdf mais uniquement la feuille de mon classeur indiqué au format Excel (Dans le cas présent la feuil1).
En vert la partie ou je crée le Pdf.
Je vous remercie par avance.
Cordialement.
Olivier
'BLAGNAC
Sub MessageOutlook_BL()
'Déclaration variables
Dim MaMessagerie As Object 'Messagerie Outlook
Dim MonMessage As Object 'Message à envoyer
Dim MonContenu As String 'Contenu du message
Dim AdresseEmail As String 'Adresse destinataire
Dim MonTDB As String 'Le nom du fichier
Dim MonClasseur As String 'Nom du classeur
'Affectation des variables ";" entre adresses si plusieurs
Set MaMessagerie = CreateObject("Outlook.Application")
Set MonMessage = MaMessagerie.createItem(0)
AdresseEmail = "contact-transparences@orange.fr"
MonTDB = "Rotation des stock"
'On crée le fichier PDF temporaire puis le supprimer
Feuil1.ExportAsFixedFormat xlTypePDF, ActiveWorkbook.Path & "\" & Feuil1.Range("D4").Value & " " & MonTDB & " " & "semaine " & Feuil1.Range("G4").Value & ".pdf", xlQualityStandard, True, False, 1, 1, False
'Création du message à envoyer
With MonMessage
.to = AdresseEmail 'Destinataire "_" Casse le code et continue le message
'.cc destinataire copie du message (Copie conforme)
'.cci destinatiare copie conforme invisible
.Subject = "Rotation semaine " & Feuil1.Range("G4").Value & " " & Feuil1.Range("D4").Value
MonContenu = "Bonjour," & vbNewLine & vbNewLine & _
"Veuillez trouver ci-joint vos rotations à faire pour la semaine" & vbNewLine & vbNewLine & _
"Cordialement"
'On affecte le contenu dans le corps du message
.body = MonContenu
'On récupère le nom du fichier dans une variable
MonClasseur = ActiveWorkbook.Path & "\" & Feuil1.Range("D4").Value & " " & MonTDB & " " & "semaine " & Feuil1.Range("G4").Value & ".pdf"
'On y joint le fichier
.attachments.Add (MonClasseur)
'On envoi le message
.send
End With
'On confirme l'envoi du mail
MsgBox "Le mail a été envoyé", vbInformation + vbOKOnly, "MESSAGE"
'On supprime le fichier temporaire
Kill ActiveWorkbook.Path & "\" & Feuil1.Range("D4").Value & " " & MonTDB & " " & "semaine " & Feuil1.Range("G4").Value & ".pdf"
'On libère la mémoire de la messagerie Outlook
Set MaMessagerie = Nothing
End Sub
Hello
Voici le code que j'ai utilisé pour réaliser ça. Il est en majeur partie tiré du MSDN :
Sub Mail_ActiveSheet()
' Fonctionne avec Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You answered NO in the security dialog."
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
TempFilePath = Environ$("temp") & "\"
'C'est ici pour modifier le nom du fichier qui va s'envoyer par mail
TempFileName = "Part of " & Sourcewb.Name & " " _
& Format(Now, "dd-mmm-yy h-mm-ss")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
'C'est ICI pour modifier les informations concernant le mail
.To = AdresseEmail
.CC = ""
.BCC = ""
.Subject = "Rotation semaine " & Feuil1.Range("G4").Value & " " & Feuil1.Range("D4").Value
.Body = MonContenu
.Attachments.Add Destwb.FullName
'Si tu ne veux pas que Outlook s'ouvre, il faut juste commenter la ligne suivante :)
.Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
J'ai essayé de reprendre les valeurs que tu utilisais dans ton propres code
Bonjour à toi Zohnya et merci,
Je me suis servi de ta réponse et j'y suis presque.
2 petites points sur lesquels tu pourrai m'aider à nouveau:
- Je copie et envoi la page active comment copier la feuil1 ?
- 'Si tu ne veux pas que Outlook s'ouvre, il faut juste commenter la ligne suivante
Que dois je mettre pour que l'envoi s'effectue sans ouvrir la fenêtre de nouveau mail à envoyer?
Merci par avance.
'Envoi Mail format Excel
Sub Mail_ActiveSheet()
' Fonctionne avec Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
Dim MonContenu As String 'Contenu du message
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "You answered NO in the security dialog."
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
TempFilePath = Environ$("temp") & "\"
'C'est ici pour modifier le nom du fichier qui va s'envoyer par mail
TempFileName = Feuil1.Range("D4").Value & " " & " Rotation de stock semaine " & Feuil1.Range("G4").Value
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
'C'est ICI pour modifier les informations concernant le mail
.To = "contact-transparences@orange.fr"
.CC = ""
.BCC = ""
.Subject = "Rotation semaine " & Feuil1.Range("G4").Value & " " & Feuil1.Range("D4").Value
MonContenu = "Bonjour," & vbNewLine & vbNewLine & _
"Veuillez trouver ci-joint vos rotations à faire pour la semaine" & vbNewLine & vbNewLine & _
"Cordialement"
.Body = MonContenu
.Attachments.Add Destwb.FullName
'Si tu ne veux pas que Outlook s'ouvre, il faut juste commenter la ligne suivante :)
.Display
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Re Olivier
Olivier TP a écrit :- Je copie et envoi la page active comment copier la feuil1 ?
Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
deviendra
Set Sourcewb = ActiveWorkbook
Worksheets("Feuil1").Copy
Set Destwb = ActiveWorkbook
Olivier TP a écrit :- 'Si tu ne veux pas que Outlook s'ouvre, il faut juste commenter la ligne suivante
.Display
Que dois je mettre pour que l'envoi s'effectue sans ouvrir la fenêtre de nouveau mail à envoyer?
'Si tu ne veux pas que Outlook s'ouvre, il faut juste commenter la ligne suivante :)
.Display
deviendra
'Si tu ne veux pas que Outlook s'ouvre, il faut juste commenter la ligne suivante :)
'.Display
Tu peux même l'effacer carrément si tu juges que tu n'en auras JAMAIS utilité.
En espérant t'être utile
HaHaHaHaHa
Après lecture de tes réponses je me sent un peu con... (Surtout pour le commenter la ligne suivante ^^
Encore merci et bonne fin de journée à toi.
Olivier TP a écrit :Après lecture de tes réponses je me sent un peu con... (Surtout pour le commenter la ligne suivante ^^
Faut pas
C'est ok pour le .display en le passant en .send le fichier s'envoi sans afficher quoi que ce soit.
Par contre passer le :
Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
En :
Set Sourcewb = ActiveWorkbook
Worksheets("Feuil1").Copy
Set Destwb = ActiveWorkbook
Ne fonctionne pas pour copier la feuil1 plutot que la feuille active.
Voir Imprim écran :
Re,
Etrange, ça fonctionne chez moi.
Es-tu sûr du nom de la feuille ? Ne l'aurais-tu pas renommée par hasard ?
ça te donne quoi comme message d'erreur ?
Tout est bon, une maladraisse de ma part.
Encore merci et bon week end.
Bonjour,
Merci pour le post.
Auriez le code pour excel 365 SVP ?
en effet, cela bloque ici :
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, _
FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
'C'est ICI pour modifier les informations concernant le mail
.To = "mail@mail.com"
.CC = ""
.BCC = ""
.Subject = "Relevé encaissements " & Feuil1.Range("A2").Value
MonContenu = "Bonjour," & vbNewLine & vbNewLine & _
"Veuillez trouver ci-joint le relevé des encaissements" & vbNewLine & vbNewLine & _
"Cordialement"
.Body = MonContenu
.Attachments.Add Destwb.FullName
'Si tu ne veux pas que Outlook s'ouvre, il faut juste commenter la ligne suivante
.Display
et ici
End With
On Error GoTo 0
.Close SaveChanges:=False
Merci beaucoup !