Macro envoi email en pdf

Bonjour ,

dans le module 4 macro envoi les onglets excel , est ce que ca serai possible de les convertir en pdf pour les envoyer .

Bonjour abdernino,

j’ai adapté le code que j'avais écrit pour l'envoi de l'email. Ci-dessous le code et vois le fichier joint:

Sub EnvoiOngletPDF()

    Dim Fichier As String
    Dim ws     As Worksheet, wsMail As Worksheet
    Dim TempFilePath As String, TempFileName As String, Destinataire As String, Sujet As String
    Dim OutApp As Object, OutMail As Object, Dict   As Object
    Dim Tableau As Variant
    Dim i As Integer, LastRow As Integer
    Dim aKey   As String, aValue As String
    Dim Adresse As String, strBody As String, DestCopie As String
    Dim Intro  As String, TexteInit As String, TexteRouge As String, Salutation As String

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set wsMail = ThisWorkbook.Sheets("Mail")
    LastRow = wsMail.Cells(Rows.Count, 4).End(xlUp).Row

    Intro = wsMail.Range("P2")
    TexteInit = wsMail.Range("P3")
    TexteRouge = wsMail.Range("P4")
    Salutation = wsMail.Range("P5")

    Tableau = wsMail.Range("D2:E" & LastRow)

    Set Dict = CreateObject("scripting.dictionary")

    For i = 1 To UBound(Tableau)
        aKey = Tableau(i, 1)
        aValue = Tableau(i, 2)
        Dict.Add aKey, aValue
    Next i

    For Each ws In Worksheets

        If ws.Name <> "Feuil1" And ws.Name <> "Modèle" And ws.Name <> "Mail" Then

            TempFilePath = ThisWorkbook.Path
            TempFileName = ws.Name
            Fichier = TempFilePath & "\" & TempFileName & ".PDF"

            With ws.PageSetup
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
            End With

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

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

            On Error Resume Next

            strBody = Intro & "<p>" & _
                      TexteInit & "<br>" & _
                      "<font color=red>" & TexteRouge & "</font color=red>" & "<br>" & Salutation
            'TexteInit = Replace(TexteInit,",",",<br>")'

            Adresse = ws.Range("B4").Value
            Destinataire = Dict.Item(Adresse)
            'DestCopie = Application.WorksheetFunction.VLookup(Destinataire, wsMail.Range("B2:C" & LastRow), 2, False)
            Sujet = ws.Range("F2")

            With OutMail
                .To = Destinataire
                .CC = DestCopie
                .BCC = ""
                .Subject = Sujet
                .HTMLBody = strBody
                .Attachments.Add Fichier
                .display
                '.Send
            End With
            On Error GoTo 0

            Kill Fichier
        End If

    Next ws

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Bonjour ,

Merci beaucoup pour ton aide

mais le débogeur s'arrete sur Dict.Add aKey, aValue il me elle existe deja et meme la barre de progression a disparu

Bonjour abdernino,

as-tu testé le fichier joint ? Le problème que tu rencontres est presque certainement causé par la présence de doublons dans la liste des agences. Il n’y a pas de barre de progression dans le code d'envoi du mail, c'est dans la macro Dispatcher.

Bonjour,

Pas de problème pour la barre de progression, mais pour l'erreur comment je peux supprimer cette erreur sachant que le code agence doit figurer sur la fiche