Création dossier, enregistrement fichier + mail

Le 17/12/2019 à 16:35

Bonjour à tous,

Je viens vers vous car j'ai épuisé toutes les solutions que je pensais trouver pour résoudre mes soucis en VBA.

J'espère vraiment que quelqu'un pourra m'aider.

Je vous explique mon problème.

J'ai crée un fichier excel pour gérer mes bons de livraison. Sur ce fichier j'ai ajouté un bouton qui doit me permettre d'effectuer les manipulations suivantes:

  • créer un dossier s'il n'existe pas encore
  • enregistrer mon fichier dans le dossier en Excel
  • envoyer un mail au client avec une version PDF

Seulement jusqu'à maintenant je suis arrivé à enregistrer le fichier en PDF mais pas dans un dossier et j'arrivais à l'envoyer au client.

J'ai essayé à partir d'informations que j'ai récupéré d'autres posts d'ajouter ce qui me manque mais malheureusement rien ne fonctionne.

Voici le code que j'ai intégré :

Sub Mail_Outlook_fichier_PDF()

Dim nomfichier As String

Dim repert As String

Dim verif As String

CurFile = "C:\Users\" & Environ("username") & "\Desktop\Bon de livraison\" & Range("B7") & " " & Range("C1") & ".pdf"

repert = "C:\Users\" & Environ("username") & "\Desktop\Bon de livraison\" & ".xslm"

If (verif = Dir(repert & "\", vbDirectory)) = vbEmpty Then

Else

MkDir "C:\Users\" & Environ("username") & "\Desktop\Bon de livraison\" & Range("B7")

repert = Workbooks(ThisWorkbook.Name).Path & "\" & repert

End If

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=CurFile, _

Quality:=xlQualityStandard, IncludeDocProperties:=True, _

OpenAfterPublish:=False

Dim OutApp As Object

Dim OutMail As Object

Set OutApp = CreateObject("Outlook.Application")

Set OutMail = OutApp.CreateItem(0)

CurFile = "C:\Users\" & Environ("username") & "\Desktop\Bon de livraison\" & Range("F1") & "du" & Range("B3") & ".pdf"

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=CurFile, _

Quality:=xlQualityStandard, IncludeDocProperties:=True, _

OpenAfterPublish:=False

With OutMail

.To = Sheets("BL").Range("D12")

.CC = ""

.BCC = ""

.Subject = "Bon de livraison n° " & Sheets("BL").Range("F1") & "du" & Sheets("BL").Range("B3")

.Attachments.Add CurFile

.Body = "Bonjour," & vbCrLf & vbCrLf & "Vous trouverez ci-joint votre bon de livraison signé." & vbCrLf & vbCrLf & "Je reste à votre disposition pour tous renseignement complémentaire." & vbCrLf

.display

End With

Set OutMail = Nothing

Set OutApp = Nothing

Application.Quit

End Sub

Je me doute qu'il doit y avoir des erreurs. Quelqu'un pourrait-il m'aider SVP ?

Je vous remercie par avance pour votre aide.

PS: Je joint le fichier.

34bon-de-livraison.xlsm (71.69 Ko)
Le 18/12/2019 à 17:20

Personne ne saurait m'aider ???

Le 19/12/2019 à 20:29

Bonjour Rom68 et le Forum,

voici une proposition, vérifie la référence aux cellules dans le noms du fichier et du classeur:

Sub test()

    Dim myPath As String, Dossier As String, Fichier As String, Classeur As String
    Dim OutApp As Object
    Dim OutMail As Object

    Dossier = ActiveSheet.Range("B7").Value
    myPath = Environ("USERPROFILE") & "\Desktop\Bon de livraison\" & Dossier & "\"

    If Len(Dir(myPath, vbDirectory)) = 0 Then
        MkDir myPath
    End If

    Fichier = myPath & Range("B7") & " " & Range("C2") & ".pdf"

    Classeur = myPath & Range("B7") & ".xlsx"

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fichier, _
                                    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                                    OpenAfterPublish:=False

    Worksheets("BL").Copy

    With ActiveWorkbook
        .SaveAs Filename:=Classeur, FileFormat:=xlOpenXMLWorkbook
        .Close SaveChanges:=False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = Sheets("BL").Range("D12")
        .CC = ""
        .BCC = ""
        .Subject = "Bon de livraison n° " & Sheets("BL").Range("F1") & " du " & Sheets("BL").Range("B3")
        .Attachments.Add Fichier
        .Body = "Bonjour," & vbCrLf & vbCrLf & "Vous trouverez ci-joint votre bon de livraison signé." & vbCrLf & vbCrLf & "Je reste à votre disposition pour tous renseignement complémentaire." & vbCrLf
        .display
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    ' Application.Quit

    Kill Fichier 'Si on veut supprimer le fichier PDF après l'envoi

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub
Le 20/12/2019 à 08:59

C'est tout simplement parfait tout fonctionne c'est top .

Merci beaucoup.

Un dernier point d'amélioration possible. Si je souhaite rajouter automatiquement la signature outlook à la fin du mail comment faire ?

Le 20/12/2019 à 17:00

Bonjour Rom68,

voici le code adapté pour ajouter la signature à l’e-mail:

Sub test2()

    Dim myPath As String, Dossier As String, Fichier As String, Classeur As String, Message As String, Signature As String
    Dim OutApp As Object
    Dim OutMail As Object

    Dossier = ActiveSheet.Range("B7").Value
    myPath = Environ("USERPROFILE") & "\Desktop\Bon de livraison\" & Dossier & "\"

    If Len(Dir(myPath, vbDirectory)) = 0 Then
        MkDir myPath
    End If

    Fichier = myPath & Range("B7") & " " & Range("C2") & ".pdf"

    Classeur = myPath & Range("B7") & ".xlsx"

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Fichier, _
                                    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                                    OpenAfterPublish:=False

    Worksheets("BL").Copy

    With ActiveWorkbook
        .SaveAs Filename:=Classeur, FileFormat:=xlOpenXMLWorkbook
        .Close SaveChanges:=False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .Display
    End With

    Signature = OutMail.HTMLbody

    Message = "<style> body{color:black;font-family:calibri;font-size: 12pt;} </style>" & _
              "<HTML><body>Bonjour,<br><br>&emsp;" & _
              "Vous trouverez ci-joint votre bon de livraison signé.<br>" & _
              "Je reste à votre disposition pour tous renseignement complémentaire.<br>" & _
              "Bien cordialement." & "</a></body>"

    With OutMail
        .To = Sheets("BL").Range("D12")
        .CC = ""
        .BCC = ""
        .Subject = "Bon de livraison n° " & Sheets("BL").Range("F1") & " du " & Sheets("BL").Range("B3")
        .Attachments.Add Fichier
        .HTMLbody = Message & Signature
        .Display
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
    ' Application.Quit

    Kill Fichier                                  'Si on veut supprimer le fichier PDF après l'envoi

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub
Rechercher des sujets similaires à "creation dossier enregistrement fichier mail"