XL 2016 Envoi mail fichier Excel renommer

FS69

XLDnaute Nouveau
Bonjour,

Je suis novice en vba et il y a quelques mois j'avais récupéré la macro ci-dessous que j'ai pu adapter à mon besoin et qui fonctionne parfaitement.

Aujourd'hui, je souhaiterais réadapter celle-ci afin d'une part : envoyer le classeur au format Excel et d'autre part sélectionner d'autres cellules renommer le fichier avant envoi et pouvoir en choisir d'autre dans l'objet du mail.

Or, en retirant les lignes relatives à la conversion en PDF ou lorsque je modifie les références de cellule dans l'objet j'ai un message d'erreur

Pouvez vous m'aider ?

Code :

Sub SendWithMail()
' Nécessite la référence : Microsoft Outlook 1x Object Library
Dim olApp As Outlook.Application
Dim olMail As MailItem
Dim CurFile As String
Set olApp = New Outlook.Application
Set olMail = olApp.CreateItem(olMailItem)
' "C:\Users\Thierry\AppData\Local\Temp\MaFeuille.pdf "
CurFile = ThisWorkbook.Path & "\" & "AAA.pdf"
ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=CurFile, _
Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

With olMail
.To = "test.test@blabla.fr"
.CC = ""
.Subject = "#" & Range("Client!H1").Value & "#" & "Décision" & " " & Range("Produits!B3").Value & " " & Range("Mon Besoin!D3").Value
.Body = "Bonjour," & vbNewLine & vbNewLine & _
"Vous trouverez ci-joint le fichier Excel" & vbNewLine & vbNewLine & _
"Cordialement"
.Attachments.Add CurFile
'.Attachments.Add "c:\My Documents\book.doc"
.Display '.Send
End With
MsgBox "Merci de vérifier que le message apparait dans -messages envoyés- dans votre messagerie OUTLOOK."
1
' Effacer les variables objets
Set olMail = Nothing
Set olApp = Nothing
Do While fich <> ""
Loop
Kill ActiveWorkbook.Path & "\" & "*.pdf" ' Là ou détruit le fichier créé

End sub
 
Solution
Merci beaucoup pour votre réponse qui réalise ce que je souhaites si mes cellules référencées sont vides , dès que je renseigne quelques choses voici ce que j'ai :
Regarde la pièce jointe 1147390
Un nom de fichier ne peut contenir une date au format dd/mm/aaaa
Correction du code ;
VB:
Sub SendWithMail()
Dim Copie As String
    Select Case True
        Case IsVide(Range("Client!H1")):        DoEvents
        Case IsVide(Range("Produits!B3")):      DoEvents
        Case IsVide(Range("'Mon Besoin'!D3")):  DoEvents
        Case Else:
            ThisWorkbook.Save
            With CreateObject("Outlook.Application").CreateItem(olMailItem)
                .To = "test.test@blabla.fr"
                .CC = ""
                .Subject = Replace("#" &...

fanch55

XLDnaute Barbatruc
Bonjour,
A tester :
VB:
Sub SendWithMail()
    ThisWorkbook.Save
    With CreateObject("Outlook.Application").CreateItem(olMailItem)
        .To = "test.test@blabla.fr"
        .CC = ""
        .Subject = "#" & Range("Client!H1").Value & _
                   "#" & "Décision" & " " & Range("Produits!B3").Value & _
                   " " & Range("'Mon Besoin'!D3").Value
        .Body = "Bonjour," & vbLf & vbLf & _
                "Vous trouverez ci-joint le fichier Excel" & vbNewLine & vbNewLine & _
                "Cordialement"
        .Attachments.Add ThisWorkbook.FullName
    .Display '.Send
    End With
    MsgBox "Merci de vérifier que le message apparait dans" & vbLf & _
           "- messages envoyés -" & vbLf & _
           "dans votre messagerie OUTLOOK."
End Sub
 

FS69

XLDnaute Nouveau
Bonjour, merci de votre retour,
Malheureusement j'ai toujours une anomalie sur les lignes :
.Subject = "#" & Range("Client!H1").Value & _
"#" & "Décision" & " " & Range("Produits!B3").Value & _
" " & Range("'Mon Besoin'!D3").Value

Cela vient de l'espace dans la feuille "Mon Besoin", je vais donc modifier le nom de cette feuille
Pourriez vous me dire comment je peux avoir le même mon fichier excel renommer comme mon sujet de mail ?
 
Dernière édition:

fanch55

XLDnaute Barbatruc
Malheureusement j'ai toujours une anomalie sur les lignes :
.Subject = "#" & Range("Client!H1").Value & _
"#" & "Décision" & " " & Range("Produits!B3").Value & _
" " & Range("'Mon Besoin'!D3").Value
Ce n'est pas l'espace dans "Mon besoin", peut-être en y a-t-il un également en début ou fin ...

Pourriez vous me dire comment je peux avoir le même mon fichier excel renommer comme mon sujet de mail ?
VB:
Sub SendWithMail()
Dim Copie As String
    ThisWorkbook.Save
    With CreateObject("Outlook.Application").CreateItem(olMailItem)
        .To = "test.test@blabla.fr"
        .CC = ""
        .Subject = "#" & Range("Client!H1").Value & _
                   "#" & "Décision" & " " & Range("Produits!B3").Value & _
                   " " & Range("'Mon Besoin'!D3").Value
        Copie = ThisWorkbook.Path & "\" & .Subject & ".xlsm"
        ThisWorkbook.SaveCopyAs Copie
        .Body = "Bonjour," & vbLf & vbLf & _
                "Vous trouverez ci-joint le fichier Excel" & vbNewLine & vbNewLine & _
                "Cordialement"
        .Attachments.Add Copie
        Kill Copie
    .Display '.Send
    End With
    MsgBox "Merci de vérifier que le message apparait dans" & vbLf & _
           "- messages envoyés -" & vbLf & _
           "dans votre messagerie OUTLOOK."

End Sub
 

FS69

XLDnaute Nouveau
Ce n'est pas l'espace dans "Mon besoin", peut-être en y a-t-il un également en début ou fin ...


VB:
Sub SendWithMail()
Dim Copie As String
    ThisWorkbook.Save
    With CreateObject("Outlook.Application").CreateItem(olMailItem)
        .To = "test.test@blabla.fr"
        .CC = ""
        .Subject = "#" & Range("Client!H1").Value & _
                   "#" & "Décision" & " " & Range("Produits!B3").Value & _
                   " " & Range("'Mon Besoin'!D3").Value
        Copie = ThisWorkbook.Path & "\" & .Subject & ".xlsm"
        ThisWorkbook.SaveCopyAs Copie
        .Body = "Bonjour," & vbLf & vbLf & _
                "Vous trouverez ci-joint le fichier Excel" & vbNewLine & vbNewLine & _
                "Cordialement"
        .Attachments.Add Copie
        Kill Copie
    .Display '.Send
    End With
    MsgBox "Merci de vérifier que le message apparait dans" & vbLf & _
           "- messages envoyés -" & vbLf & _
           "dans votre messagerie OUTLOOK."

End Sub
Merci beaucoup pour votre réponse qui réalise ce que je souhaites si mes cellules référencées sont vides , dès que je renseigne quelques choses voici ce que j'ai :
1660634335170.png
 
Dernière édition:

fanch55

XLDnaute Barbatruc
Merci beaucoup pour votre réponse qui réalise ce que je souhaites si mes cellules référencées sont vides , dès que je renseigne quelques choses voici ce que j'ai :
Regarde la pièce jointe 1147390
Un nom de fichier ne peut contenir une date au format dd/mm/aaaa
Correction du code ;
VB:
Sub SendWithMail()
Dim Copie As String
    Select Case True
        Case IsVide(Range("Client!H1")):        DoEvents
        Case IsVide(Range("Produits!B3")):      DoEvents
        Case IsVide(Range("'Mon Besoin'!D3")):  DoEvents
        Case Else:
            ThisWorkbook.Save
            With CreateObject("Outlook.Application").CreateItem(olMailItem)
                .To = "test.test@blabla.fr"
                .CC = ""
                .Subject = Replace("#" & Range("Client!H1").Value & _
                                   "#" & "Décision" & " " & Range("Produits!B3").Value & _
                                   " " & Range("'Mon Besoin'!D3").Value, _
                                   "/", "_")
                On Error GoTo Exit_Error
                Copie = ThisWorkbook.Path & "\" & .Subject & ".xlsm"
                ThisWorkbook.SaveCopyAs Copie
                
                .Body = "Bonjour," & vbLf & vbLf & _
                        "Vous trouverez ci-joint le fichier Excel" & vbLf & vbLf & _
                        "Cordialement"
                .Attachments.Add Copie
                Kill Copie
            .Display '.Send
            End With
            MsgBox "Merci de vérifier que le message apparait dans" & vbLf & _
                   "- messages envoyés -" & vbLf & _
                   "dans votre messagerie OUTLOOK."
    End Select
Exit Sub

Exit_Error:
    MsgBox "Erreur probable dans le nom de fichier" & vbLf & _
            Err.Description, vbCritical, "Abandon"

End Sub
Function IsVide(Rng As Range) As Boolean
    IsVide = Rng.Value = ""
    If IsVide Then MsgBox Rng.AddressLocal(external:=True) & " vide !!!", vbCritical, "Abandon"
End Function
 

FS69

XLDnaute Nouveau
Un nom de fichier ne peut contenir une date au format dd/mm/aaaa
Correction du code ;
VB:
Sub SendWithMail()
Dim Copie As String
    Select Case True
        Case IsVide(Range("Client!H1")):        DoEvents
        Case IsVide(Range("Produits!B3")):      DoEvents
        Case IsVide(Range("'Mon Besoin'!D3")):  DoEvents
        Case Else:
            ThisWorkbook.Save
            With CreateObject("Outlook.Application").CreateItem(olMailItem)
                .To = "test.test@blabla.fr"
                .CC = ""
                .Subject = Replace("#" & Range("Client!H1").Value & _
                                   "#" & "Décision" & " " & Range("Produits!B3").Value & _
                                   " " & Range("'Mon Besoin'!D3").Value, _
                                   "/", "_")
                On Error GoTo Exit_Error
                Copie = ThisWorkbook.Path & "\" & .Subject & ".xlsm"
                ThisWorkbook.SaveCopyAs Copie
               
                .Body = "Bonjour," & vbLf & vbLf & _
                        "Vous trouverez ci-joint le fichier Excel" & vbLf & vbLf & _
                        "Cordialement"
                .Attachments.Add Copie
                Kill Copie
            .Display '.Send
            End With
            MsgBox "Merci de vérifier que le message apparait dans" & vbLf & _
                   "- messages envoyés -" & vbLf & _
                   "dans votre messagerie OUTLOOK."
    End Select
Exit Sub

Exit_Error:
    MsgBox "Erreur probable dans le nom de fichier" & vbLf & _
            Err.Description, vbCritical, "Abandon"

End Sub
Function IsVide(Rng As Range) As Boolean
    IsVide = Rng.Value = ""
    If IsVide Then MsgBox Rng.AddressLocal(external:=True) & " vide !!!", vbCritical, "Abandon"
End Function
Merci beaucoup, ça marche parfaitement :)
 

Discussions similaires

Réponses
6
Affichages
268

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG