Modifier VBA pour envoie de pdf par mail Outlook

Bonjour à tous,

Et oui n'étant toujours pas professionnel en VBA, je vais avoir besoin d'un peu d'aide.

Je suis partie sur une base de macro pour convertir mon onglet actif, en PDF avec enregistrement, puis envoie par mail.

Ceci fonctionne parfaitement, mais j'aimerais améliorer quelque point:

  • J'enregistre toujours les PDF au même endroit, faudrait qu'elle pointe directement sur le dossier souhaité.
  • Que le PDF prenne le nom du fichier excel (je suppose remplacé xSht.Name par ?)
  • Et avoir un message, car quand j'insère un ".body" avant mon ".Attachements.Add x Folder" j'ai plus de signature mail.

Merci d'avance.

Voici mon code actuel.

Sub Mail_interne()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Set xSht = ActiveSheet
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)

If xFileDlg.Show = True Then
   xFolder = xFileDlg.SelectedItems(1)
Else
   MsgBox "Vous devez spécifier un dossier dans lequel enregistrer le fichier PDF." & vbCrLf & vbCrLf & "Appuyez sur OK pour quitter cette macro.", vbCritical, "Vous devez spécifier un dossier de destination"
   Exit Sub
End If
xFolder = xFolder + "\" + xSht.Name + ".pdf"

'Check if file already exist
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Voulez-vous l'écraser?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "Si vous n'écrasez pas le PDF existant, vous ne pouvez pas continuer." _
                    & vbCrLf & vbCrLf & "Appuyez sur OK pour quitter cette macro.", vbCritical, "Quitter la macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Impossible de supprimer le fichier existant. Veuillez vous assurer que le fichier n'est pas ouvert ou protégé en écriture." _
                    & vbCrLf & vbCrLf & "Appuyez sur OK pour quitter cette macro.", vbCritical, "Impossible de supprimer le fichier"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
    'Save as PDF file
    xSht.ExportAsFixedFormat Type:=xlTypePDF, FileName:=xFolder, Quality:=xlQualityStandard

    'Create Outlook email
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = "mails"
        .CC = ""
        .Subject = xSht.Name + " pour information - Action préventive"
        .Attachments.Add xFolder

        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "La feuille de calcul active ne peut pas être vide"
  Exit Sub
End If
End Sub

bonsoir,

bonsoir le forum,

J'enregistre toujours les PDF au même endroit, faudrait qu'elle pointe directement sur le dossier souhaité.

c'est ce que fait la macro me semble-t-il

- Que le PDF prenne le nom du fichier excel (je suppose remplacé xSht.Name par ?)

remplace ta ligne

xFolder = xFolder + "\" + xSht.Name + ".pdf"

par

xFolder = xFolder + "\" + Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) + ".pdf"

- Et avoir un message, car quand j'insère un ".body" avant mon ".Attachements.Add x Folder" j'ai plus de signature mail.

mettre une signature dans le body

Merci de ta réponse, j'essaierai cela demain! J'ai pas l'ordi sous la main!

Elle s'arrête au dossier juste avant,mais ne rentre pas dans le dossier même !

Pour la signature, je t'avoue que j'ai pas tout compris, car actuellement la macro reprends bien ma signature, c'est juste que je n'arrive pas à ajouter un corps de texte!

Merci d'avance de ta réponse !

Bonjour,

Je viens de faire le test, c'est parfait pour le changement de la ligne, j'ai bien le nom de mon fichier et non plus de l'onglet.

J'ai essayé plusieurs fois, et non elle ne pointe pas sur un dossier spécifique.

Bonjour,

je crois que je ne comprends pas ce que tu veux dire par dossier spécifique.

peux-tu mettre un exemple d'un répertoire choisi par l'utilisateur, le nom d'un classeur et le nom complet du fichier pdf que tu voudrais avoir ?

Bonjour,

Excuse moi si ma demande n'est pas clair.

Je souhaiterais que les PDF, ce range toujours a cette endroit:

C:\Users\baptistex1\Documents\PDF

Pour le nom du PDF, j'ai réussis à modifier pour qu'il prenne le nom, de mon fichier excel! ça c'est régler!

Merci d'avance de ta réponse.

Bonjour,

voici une correction,

Sub Mail_interne()
    Dim xSht As Worksheet
    Dim xFileDlg As FileDialog
    Dim xFolder As String
    Dim xYesorNo As Integer
    Dim xOutlookObj As Object
    Dim xEmailObj As Object
    Dim xUsedRng As Range

    Set xSht = ActiveSheet

    xFolder = "C:\Users\baptistex1\Documents\PDF\" + Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) + ".pdf"

    'Check if file already exist
    If Len(Dir(xFolder)) > 0 Then
        xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Voulez-vous l'écraser?", _
                          vbYesNo + vbQuestion, "File Exists")
        On Error Resume Next
        If xYesorNo = vbYes Then
            Kill xFolder
        Else
            MsgBox "Si vous n'écrasez pas le PDF existant, vous ne pouvez pas continuer." _
                   & vbCrLf & vbCrLf & "Appuyez sur OK pour quitter cette macro.", vbCritical, "Quitter la macro"
            Exit Sub
        End If
        If Err.Number <> 0 Then
            MsgBox "Impossible de supprimer le fichier existant. Veuillez vous assurer que le fichier n'est pas ouvert ou protégé en écriture." _
                   & vbCrLf & vbCrLf & "Appuyez sur OK pour quitter cette macro.", vbCritical, "Impossible de supprimer le fichier"
            Exit Sub
        End If
    End If

    Set xUsedRng = xSht.UsedRange
    If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
        'Save as PDF file
        xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xFolder, Quality:=xlQualityStandard

        'Create Outlook email
        Set xOutlookObj = CreateObject("Outlook.Application")
        Set xEmailObj = xOutlookObj.CreateItem(0)
        With xEmailObj
            .Display
            .To = "mails"
            .CC = ""
            .Subject = xSht.Name + " pour information - Action préventive"
            .Attachments.Add xFolder

            If DisplayEmail = False Then
                '.Send
            End If
        End With
    Else
        MsgBox "La feuille de calcul active ne peut pas être vide"
        Exit Sub
    End If
End Sub

Il m'indique erreur d'exécution '1004'

A priori l'erreur viendrait de cette ligne :

xSht.ExportAsFixedFormat Type:=xlTypePDF, FileName:=xFolder, Quality:=xlQualityStandard

Autant pour moi, j'avais fais une erreur dans une ligne.

Par contre il ne me joint plus mon fichier en PDF à mon mail, et ne l'enregistre pas à l'endroit spécifié.

Il y a qu'une seule chose que je n'arrive pas à corriger, la signature ce place avant mon message et non pas après ???

Après correction, voici mon code actuel :

Sub Mail_interne2()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range

Set xSht = ActiveSheet

xFolder = "C:\Chemin d'accès" + Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) + ".pdf"

'Vérifier si le fichier existe déjà
If Len(Dir(xFolder)) > 0 Then
    xYesorNo = MsgBox(xFolder & " already exists." & vbCrLf & vbCrLf & "Voulez-vous l'écraser?", _
                      vbYesNo + vbQuestion, "File Exists")
    On Error Resume Next
    If xYesorNo = vbYes Then
        Kill xFolder
    Else
        MsgBox "Si vous n'écrasez pas le PDF existant, vous ne pouvez pas continuer." _
                    & vbCrLf & vbCrLf & "Appuyez sur OK pour quitter cette macro.", vbCritical, "Quitter la macro"
        Exit Sub
    End If
    If Err.Number <> 0 Then
        MsgBox "Impossible de supprimer le fichier existant. Veuillez vous assurer que le fichier n'est pas ouvert ou protégé en écriture." _
                    & vbCrLf & vbCrLf & "Appuyez sur OK pour quitter cette macro.", vbCritical, "Impossible de supprimer le fichier"
        Exit Sub
    End If
End If

Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then

    'Enregistrer en fichier PDF
    xSht.ExportAsFixedFormat Type:=xlTypePDF, FileName:=xFolder, Quality:=xlQualityStandard

    'Créer un email Outlook
    Set xOutlookObj = CreateObject("Outlook.Application")
    Set xEmailObj = xOutlookObj.CreateItem(0)
    With xEmailObj
        .Display
        .To = "Mails"
        .CC = "Mails"
        .Subject = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) + " pour information - Action préventive"
        .Body = "Veuillez trouver ci-joint."
        .Attachments.Add xFolder
        .GetInspector.CommandBars.Item("Insert").Controls("Signature").Controls(1).Execute

        If DisplayEmail = False Then
            '.Send
        End If
    End With
Else
  MsgBox "La feuille de calcul active ne peut pas être vide"
  Exit Sub
End If
End Sub

bonjour,

je te confirme que la macro fonctionne telle quelle chez moi.

tu confirmes que le mail est bien créé ?

tu peux ajouter une instruction

msgbox xfolder

avant

xsht.exportasfixedformat ...

et mettre le contenu de l'affichage ici

Bonjour,

C'est parfait tout fonctionne très bien, le mail est bien créé.

Mais toujours cette signature avant le corps du mail.

Merci bien de ton aide, j'ai l'impression d'avancer à grand pas.

Bonjour, Baptiste & h2so4

j'arrive comme un cheveu sur la soupe ...

regarde si cet exemple te permet de mettre la signature après le texte

restera alors à adapter !

essaie aussi ceci :

remplace

.Body = "Veuillez trouver ci-joint."

par

.HTMLbody = "Veuillez trouver ci-joint." & "<br>" & .HTMLbody 

Salut Steelson,

Je t'avouerai que la première macro, j'y comprends absolument rien !

La ligne que tu m'as proposé fais exactement le boulot que je veux, la signature est bien après le texte.

Seul bémol il n'utilise pas la typographie de notre charte, et j'ai le texte sur une ligne.

Je remets mon code :

.HTMLBody = "Bonjour à tous," & vbCrLf & vbCrLf & "Suite à un problème rencontré, je vous demanderai de prendre note de l'action préventive en pièce jointe. " & "<br>" & .HTMLBody

Seul bémol il n'utilise pas la typographie de notre charte, et j'ai le texte sur une ligne.

Dans ce cas, il faudrait programmer cette typologie en html par les balises ad-hoc.

Peux-tu me donner la police, la taille, la couleur etc. ? ou bien fais une recherche sur gogol

Remplace aussi vbCrLf par "<br>" qui est la balise de retour à la ligne en html

Merci de ton aide Steelson, mais tu me parles chinois !

La police est Century Gothic, taille 11!

Ok je vais remplacer cela.

Après recherche sur internet, j'arrive à ce code.

.HTMLBody = "<font face=""century gothic""><font size=""4"">Bonjour,<br><br>" & "<br>" & "<font face=""century gothic""><font size=""4"">Suite à un problème rencontré, je vous demanderai de prendre note de l'action préventive en pièce jointe. " & "<br>" & .HTMLBody

Le souci c'est que la taille de police est 13.5 avec 4, Et si je change pour 3 je suis a 10 ???

Être si proche du but.

génial ! maintenant tu parles chinois aussi !!

esaie ceci

.HTMLBody = "<font face=""century gothic""><font size=""11px"">Bonjour,<br><br><br>Suite à un problème rencontré, je vous demanderai de prendre note de l'action préventive en pièce jointe.<br></font></font>" & .HTMLBody

Et oui, j'apprends et découvre ! J'adore!

Ta solution ne fonctionne pas, désolé!

Rechercher des sujets similaires à "modifier vba envoie pdf mail outlook"