[Réglé] Publipostage Word Excel Outlook le fichier Word en pdf

Sub Macro1()
    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        "C:\Users\" & Environ("username") & "\Desktop\" & "Doc2.pdf", ExportFormat:=wdExportFormatPDF
End Sub

Sub envoimail()
Dim Objet, Corps, mois, rep, fichier(1 To 3) As String
Dim PremAdress, Strcc, CopieC, AdressMailBCC As String
Dim Outlook, Mail As Object, cel as range
 
mois = LCase(Format(Date, "mmmm"))
Objet = "Rapport d'appels du mois d'" & mois

Corps = "Bonjour, " & _
vbCrLf & vbCrLf & _
"ci-joint le fichier des appels du mois " & "d'" & mois & " pour votre agence." & _
vbCrLf & vbCrLf & _
"Nous restons bien entendu à votre disposition pour tout renseignement complémentaire." & _
vbCrLf & vbCrLf & _
"Cordialement." & _
vbCrLf & vbCrLf & vbCrLf & _
"D. Mélanie - Assistante de Direction"


rep = "C:\Users\" & Environ("username") & "\Desktop\Nouveau dossier\"
fichier1 = rep & "Classe.xls"
fichier2 = rep & "Justice.doc"
fichier3 = rep & "lettre.pdf"

With Feuil1       'Nom complet  et adresse mail
PremAdresse = .Range("d5") & "<" & .Range("e5") & ">" & ";"
For Each cel In .Range([M4], [M65536].End(xlUp))
                               'Nom complet  et adresse mail
        Strcc = Strcc & cel.Offset(0, -2).Value & "<" & cel.Value & ">" & ";"
    Next cel
    CopieC = Split(Strcc, ";")
    
    For i = 0 To UBound(CopieC) - 1
        If CopieC(i) = AdressMailBCC Then
        Exit For
        Else
            AdressMailBCC = AdressMailBCC & CopieC(i) & ";"
        End If
    Next i
End With

Set Outlook = CreateObject("Outlook.Application")
    Set Mail = Outlook.CreateItem(0)
 
    With Mail
        .To = PremAdresse
        .CC = Mid(AdressMailBCC, 1, Len(AdressMailBCC) - 1)
        .Subject = Objet
        .Body = Corps
        .Attachments.Add fichier1
        .Attachments.Add fichier2
        .Attachments.Add fichier3
        .Display
    End With
End Sub

Private Sub WordDoc_Click()
    Dim oApp As Word.Application, doc As Word.Document
  Range("A2").Select
    On Error Resume Next
    nf = ThisWorkbook.Path & "\modele.doc"
    Set oApp = CreateObject("Word.Application")
    oApp.Visible = True
    Set doc = oApp.Documents.Open(nf)
    If Err <> 0 Then
      MsgBox "Le fichier doit être dans " & ThisWorkbook.Path, , "Contacts Outlook"
      Exit Sub
    End If
    On Error GoTo 0        ' Annule la gestion d'erreur
    '--
    titre = TextBox1.Value
    nom = TextBox2.Value
    rue = TextBox3.Value
    codepostal = TextBox4.Value
    ville = TextBox5.Value
    civilité = TextBox1.Value
    '--
    With doc
      .Bookmarks("titre").Range.Text = titre
      .Bookmarks("civilité").Range.Text = titre
      .Bookmarks("nom").Range.Text = nom
      .Bookmarks("rue").Range.Text = rue
      .Bookmarks("codepostal").Range.Text = codepostal
      .Bookmarks("ville").Range.Text = ville
      .Bookmarks("title").Range.Text = titre
    End With
    nom_doc = ThisWorkbook.Path & "\" & nom & ".doc"
    doc.SaveAs nom_doc
        doc.ExportAsFixedFormat OutputFileName:= _
        ThisWorkbook.Path & "\Pdf-doc\" & nom, ExportFormat:=wdExportFormatPDF
    nom_pdf = ThisWorkbook.Path & "\Pdf-doc\" & nom & ".pdf"
    oApp.Quit
    '------------------------ envoi par mail
    Dim olApp As Outlook.Application
    Dim Objet As Object
    Dim Msg As MailItem
    Dim strline As String
    strline = "Bonjour" & " " & TextBox1 & ","
    Set olApp = New Outlook.Application
    Set Msg = olApp.CreateItem(olMailItem)
    Msg.To = TextBox9.Value
    Msg.Subject = ""
    Msg.Body = ""
    Msg.Attachments.Add Source:=nom_doc
    Msg.Attachments.Add Source:=nom_pdf
    Msg.Display
    Set olApp = Nothing
    ActiveCell.Offset(1, 0).Select
  Set Objet = CreateObject("Scripting.FileSystemObject")
  Objet.movefile nom_doc, ThisWorkbook.Path & "\Word-doc\"
End Sub