Ouvrir la fenêtre "Nouveau message" de Outlook via Excel

[Mjgreg67]

Bonjour tout le monde,

Mon but était de créer un code permettant d'ouvrir, à partir d'un classeur Excel, la fenêtre "Nouveau message" d'Outlook avec pour pièce jointe le fichier en question mais au format PDF.
Ce code fonctionne mais pas tout le temps :/ (D'ailleurs j'ai finalement trouvé ce code sur internet).

En fait le problème que j'ai c'est que quelque fois le document Excel ne se met pas en pièce jointe... Tout s'applique correctement sauf cette pièce jointe. J'ai déjà essayé de fermer le document et de le réouvrir mais rien à faire. La seule solution que j'ai trouvé pour pallier à ce problème et de redémarrer l'ordinateur.

Si quelqu'un s'y connait en matière de code, pouvez vous m'expliquer pourquoi celui ci ne fonctionne pas tout le temps ? Et comment peut on corriger cette erreur ?

Je vous remercie beaucoup

Voici le code :

Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
                 OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant

    'Test to see if the Microsoft Create/Send add-in is installed.
   If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the PDF file.
           FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                  Title:="Create PDF")

            'If you cancel this dialog, exit the function.
           If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False then test to see if the PDF
       'already exists in the folder and exit the function if it does.
       If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        'Now export the PDF file.
       On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0

        'If the export is successful, return the file name.
       If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
    End If
End Function

Function RDB_Mail_PDF_Outlook(FileNamePDF As String, StrTo As String, _
                              StrSubject As String, StrBody As String, Send As Boolean)
    Dim OutApp As Object
    Dim OutMail As Object

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

    On Error Resume Next
    With OutMail
        .To = StrTo
        .CC = ""
        .BCC = ""
        .Subject = StrSubject
        .Body = StrBody
        .Attachments.Add FileNamePDF
        If Send = True Then
            .Send
        Else
            .Display
        End If
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Function

Sub Envoyerpdf()
   tmp = RDB_Create_PDF(ActiveSheet, "monpdf.pdf", True, False)
    tmp = RDB_Mail_PDF_Outlook("monpdf.pdf", ActiveSheet.Range("A5").Value, "Objet ici", _
         "Texte ici" _
         & vbNewLine & vbNewLine & "Cordialement,", False)
End Sub