XL 2016 Envoi pièce jointe par mail

SALAH

XLDnaute Occasionnel
Bonjour le forum

Je reviens vers vous car j' avais posté une discussion concernant l' envoi de mail avec pièce jointe en pdf.

Serait il possible que vous m' aidiez à utiliser le même code qui marche parfaitement mais au lieu d' avoir le fichier en pdf il serait en xls

En fait je m' explique, j' aimerais créer un mail et envoyer l' onglet du classeur en xls

Ci-joint le code ci-dessous à remodifier

Merci à vous tous

Private Sub CommandButton2_Click()
Dim destinataire, sujet, fichierjoint As String
destinataire = "cerise@free.fr"
sujet = "Fichier " & Range("D9").Value

Sheets("Sheet1").ExportAsFixedFormat Type:=xlTypePDF, Filename:=ActiveWorkbook.Path & "\" & "Sheet1.pdf"

text1 = " Bonjour " & "<br>"
text2 = "<br>"
text3 = " Je te prie de trouver ci-joint le fichier en pdf " & "<br><br>"
text4 = "Bien Cordialement" & "<br><br>"
text5 = "Salah" & "<br><br>"
text6 = "Tél.: 01-45-23-12-11"

Body = text1 & text2 & text3 & text4 & text5 & text6


fichierjoint = "C:\Users\Salah\Desktop\donnees\Sheet1.xls"

strcommand = "C:\Program Files (x86)\Mozilla Thunderbird\Thunderbird.exe"
strcommand = strcommand & " -compose " & "to='" & destinataire & "'"
strcommand = strcommand & "," & "subject=" & sujet & ","
strcommand = strcommand & "body=" & Body
strcommand = strcommand & "," & "attachment=file:///" & fichierjoint
'MsgBox strcommand

Call Shell(strcommand, vbNormalFocus)

End Sub
 

xUpsilon

XLDnaute Accro
Bonjour,

Si ton fichier est déjà présent avec le nom "Sheet1.xls" dans le dossier "donnees" alors je pense qu'il te suffit de supprimer la ligne qui s'occupe d'imprimer ton excel en pdf.
Par contre un truc me titille, pourquoi fichierjoint est déjà Sheet1.xls ? Tu dis pourtant envoyer un pdf à l'heure actuelle ?

Bonne continuation
 

SALAH

XLDnaute Occasionnel
Bonjour le forum, xUpsilon

En fait c' est une erreur c'est .pdf et non .xls

Je joins le ficher pour une meilleur compréhension
Ce qui m' intéresse le plus c' est d' avoir la pièce jointe en .xls

Merci
 

Pièces jointes

  • Application.xlsm
    29.5 KB · Affichages: 22

Sequoyah

XLDnaute Nouveau
Bonjour Salah et le forum,
une solution à tester:
VB:
Private Sub CommandButton2_Click()

    Dim NewWbk    As Workbook
    Dim destinataire As String, Sujet As String, Message As String
    Dim FilePath As String, FileName As String

    destinataire = "cerise@free.fr"
    FilePath = Environ$("temp") & "\"
    Sujet = "Fichier " & ThisWorkbook.Sheets(1).Range("D9").Value
        
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    ActiveSheet.Copy
    
    Set NewWbk = ActiveWorkbook
    
    With NewWbk
        FileName = .Sheets(1).Name
        .SaveAs FilePath & FileName, FileFormat:=51 '56 pour xls
    End With
    
    PieceJointe = NewWbk.FullName
    
    text1 = " Bonjour " & "<br>"
    text2 = "<br>"
    text3 = " Je te prie de trouver ci-joint le fichier......." & "<br><br>"
    text4 = "Bien Cordialement" & "<br><br>"
    text5 = "Salah" & "<br><br>"
    text6 = "Tél.: 01-45-23-12-11"
    
    Message = text1 & text2 & text3 & text4 & text5 & text6
    
   strcommand = "C:\Program Files (x86)\Mozilla Thunderbird\Thunderbird.exe"
   strcommand = strcommand & " -compose " & "to= '" & destinataire & "'"
   strcommand = strcommand & "," & "subject=" & Sujet & ","
   strcommand = strcommand & "body=" & Message
   strcommand = strcommand & "," & "attachment=" & PieceJointe
    
    Call Shell(strcommand, vbNormalFocus)
    
    NewWbk.Close
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
End Sub
 

SALAH

XLDnaute Occasionnel
Bonjour le forum, Sequoyah, xUpsilon

Sa marche à merveille Sequoyah, exactement ce que je veux
sinon une autre précision si cela ne te dérange pas serait il possible que la pièce jointe porte le même nom que la cellule D9,?
En te remerciant par avance
 
Dernière édition:

Sequoyah

XLDnaute Nouveau
Bonjour Salah,
merci pour ton retour. J'espère ne pas avoir mal compris, si le nom de l'onglet est dans la cellule D9, la feuille correspondante est copiée. J'ai aussi ajouté le code pour supprimer les boutons de la copie du fichier. Voici le code corrigé:
VB:
Private Sub CommandButton2_Click()
'https://www.excel-downloads.com/threads/envoi-piece-jointe-par-mail.20038977/

    Dim NewWbk    As Workbook
    Dim destinataire As String, Sujet As String, Message As String, Feuille As String
    Dim FilePath As String, FileName As String
    Dim btn As Shape

    destinataire = "cerise@free.fr"
    FilePath = Environ$("temp") & "\"
    Sujet = "Fichier " & ThisWorkbook.Sheets(1).Range("D9").Value
    Feuille = ThisWorkbook.Sheets(1).Range("D9").Value
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    Sheets(Feuille).Copy
    
    Set NewWbk = ActiveWorkbook
    
    With NewWbk
        FileName = .Sheets(1).Name
                
        For Each btn In ActiveSheet.Shapes
            If btn.AutoShapeType = msoShapeStyleMixed Then btn.Delete
        Next
                
        .SaveAs FilePath & FileName, FileFormat:=51 '56 pour xls
    End With
    
    PieceJointe = NewWbk.FullName
    
    text1 = " Bonjour " & "<br>"
    text2 = "<br>"
    text3 = " Je te prie de trouver ci-joint le fichier......." & "<br><br>"
    text4 = "Bien Cordialement" & "<br><br>"
    text5 = "Salah" & "<br><br>"
    text6 = "Tél.: 01-45-23-12-11"
    
    Message = text1 & text2 & text3 & text4 & text5 & text6
    
    strcommand = "C:\Program Files (x86)\Mozilla Thunderbird\Thunderbird.exe"
    strcommand = strcommand & " -compose " & "to= '" & destinataire & "'"
    strcommand = strcommand & "," & "subject=" & Sujet & ","
    strcommand = strcommand & "body=" & Message
    strcommand = strcommand & "," & "attachment=" & PieceJointe
    
    Call Shell(strcommand, vbNormalFocus)
    
    NewWbk.Close
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
End Sub
 

SALAH

XLDnaute Occasionnel
Bonjour Salah,
merci pour ton retour. J'espère ne pas avoir mal compris, si le nom de l'onglet est dans la cellule D9, la feuille correspondante est copiée. J'ai aussi ajouté le code pour supprimer les boutons de la copie du fichier. Voici le code corrigé:
VB:
Private Sub CommandButton2_Click()
'https://www.excel-downloads.com/threads/envoi-piece-jointe-par-mail.20038977/

    Dim NewWbk    As Workbook
    Dim destinataire As String, Sujet As String, Message As String, Feuille As String
    Dim FilePath As String, FileName As String
    Dim btn As Shape

    destinataire = "cerise@free.fr"
    FilePath = Environ$("temp") & "\"
    Sujet = "Fichier " & ThisWorkbook.Sheets(1).Range("D9").Value
    Feuille = ThisWorkbook.Sheets(1).Range("D9").Value
   
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With
   
    Sheets(Feuille).Copy
   
    Set NewWbk = ActiveWorkbook
   
    With NewWbk
        FileName = .Sheets(1).Name
               
        For Each btn In ActiveSheet.Shapes
            If btn.AutoShapeType = msoShapeStyleMixed Then btn.Delete
        Next
               
        .SaveAs FilePath & FileName, FileFormat:=51 '56 pour xls
    End With
   
    PieceJointe = NewWbk.FullName
   
    text1 = " Bonjour " & "<br>"
    text2 = "<br>"
    text3 = " Je te prie de trouver ci-joint le fichier......." & "<br><br>"
    text4 = "Bien Cordialement" & "<br><br>"
    text5 = "Salah" & "<br><br>"
    text6 = "Tél.: 01-45-23-12-11"
   
    Message = text1 & text2 & text3 & text4 & text5 & text6
   
    strcommand = "C:\Program Files (x86)\Mozilla Thunderbird\Thunderbird.exe"
    strcommand = strcommand & " -compose " & "to= '" & destinataire & "'"
    strcommand = strcommand & "," & "subject=" & Sujet & ","
    strcommand = strcommand & "body=" & Message
    strcommand = strcommand & "," & "attachment=" & PieceJointe
   
    Call Shell(strcommand, vbNormalFocus)
   
    NewWbk.Close
   
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = True
        .EnableEvents = True
    End With
   
End Sub
 

Sequoyah

XLDnaute Nouveau
Bonjour Salah et le forum:),
je n’avais pas bien compris ta demande, la solution est encore plus simple, voici le code adapté:
VB:
Private Sub CommandButton2_Click()

    Dim NewWbk    As Workbook
    Dim destinataire As String, Sujet As String, Message As String
    Dim FilePath As String, FileName As String

    destinataire = "cerise@free.fr"
    FilePath = Environ$("temp") & "\"
    Sujet = "Fichier " & ThisWorkbook.Sheets(1).Range("D9").Value
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    ActiveSheet.Copy
    
    Set NewWbk = ActiveWorkbook
    
    With NewWbk
        FileName = .Sheets(1).Range("D9").Value
        
        For Each btn In ActiveSheet.Shapes
            If btn.AutoShapeType = msoShapeStyleMixed Then btn.Delete
        Next
        .SaveAs FilePath & FileName, FileFormat:=51 '56 pour xls
    End With
    
    PieceJointe = NewWbk.FullName
    
    text1 = " Bonjour " & "<br>"
    text2 = "<br>"
    text3 = " Je te prie de trouver ci-joint le fichier......." & "<br><br>"
    text4 = "Bien Cordialement" & "<br><br>"
    text5 = "Salah" & "<br><br>"
    text6 = "Tél.: 01-45-23-12-11"
    
    Message = text1 & text2 & text3 & text4 & text5 & text6
    
    strcommand = "C:\Program Files (x86)\Mozilla Thunderbird\Thunderbird.exe"
    strcommand = strcommand & " -compose " & "to= '" & destinataire & "'"
    strcommand = strcommand & "," & "subject=" & Sujet & ","
    strcommand = strcommand & "body=" & Message
    strcommand = strcommand & "," & "attachment=" & PieceJointe
    
    Call Shell(strcommand, vbNormalFocus)
    
    NewWbk.Close
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
End Sub
 

Discussions similaires

Réponses
1
Affichages
1 K
Compte Supprimé 979
C