Publipostage Word et envois pièces jointes Pdf

[Lone-wolf]

Bonsoir à tous

Pour celles ou ceux qui seraient interéssés, voici le code et fichier exemple. Mais avant d'utiliser la macro, créez un nouveau document Word. Dans le document, au lieu des champs(publipostage), créer autant de signets que vous avez besoin.

Exemple: titre, nom, prenom, adresse, cp, ville, civilite;(civilite = titre), vu que l'on ne peux pas avoir deux fois le même signet.

Option Explicit

Sub Envois_Publipostage()
Dim titre$, nom$, prenom$, adresse$, cp$, ville$, civilite$, _
AdrMail$, Nom_doc$, Nom_pdf$, Fichier$, Strcc$
Dim x&, k&, lig%, num%, t#, cel  As Range
Dim WrdApp As Word.Application, doc As Word.Document

    'Application.WindowState = xlMinimized
   On Error GoTo Fin
   
       With Sheets("Base")
        For Each cel In .Range("a2:a19")
          Strcc = Strcc & cel.Offset(0, 0).Value & " " & cel.Offset(0, 7).Value & ";"
        Next cel
        End With

    lig = 1
    For k = 1 To 18
    k = k + 1
        For x = 1 To 17
    lig = lig + 1
    Sheets("Publipostage").Range("e2") = Sheets("Base").Cells(lig, 1)
   

    Fichier = ThisWorkbook.Path & "\Modele.doc"
    Set WrdApp = CreateObject("Word.Application")
    WrdApp.Visible = False
    Set doc = WrdApp.Documents.Open(Fichier)
    If Err <> 0 Then
      MsgBox "Le fichier doit être dans " & ThisWorkbook.Path, , "Envois PDF"
      Exit Sub
    End If
   
With Sheets("Publipostage")
    titre = .Range("b2")
    prenom = .Range("b3")
    nom = .Range("c3")
    adresse = .Range("b4")
    cp = .Range("b5")
    ville = .Range("c5")
    civilite = .Range("b2")
    AdrMail = .Range("b6")
   With doc
      .Bookmarks("titre").Range.Text = titre
      .Bookmarks("nom").Range.Text = nom
      .Bookmarks("prenom").Range.Text = prenom
      .Bookmarks("adresse").Range.Text = adresse
      .Bookmarks("cp").Range.Text = cp
      .Bookmarks("ville").Range.Text = ville
      .Bookmarks("civilite").Range.Text = civilite & ","
    End With
    Nom_doc = ThisWorkbook.Path & "\Fichiers doc\" & AdrMail & ".doc"
    doc.SaveAs Nom_doc
        doc.ExportAsFixedFormat OutputFileName:= _
        ThisWorkbook.Path & "\Fichiers pdf\" & AdrMail & ".pdf", ExportFormat:=wdExportFormatPDF
    Nom_pdf = ThisWorkbook.Path & "\Fichiers pdf\" & AdrMail & ".pdf"
      End With
          WrdApp.Quit

    Dim OlApp As Outlook.Application
    Dim Msg As MailItem
    Dim EnvoisA$, Objet$, Corp$, Mois$, NomPdf$, NomDoc$, Rep_Pdf$, _
    Rep_Doc$, Rep$, Chemin$, Lt$, CopieC$, AdressBCC$, Adr$, c As Range
   
    Set OlApp = New Outlook.Application
    Set Msg = OlApp.CreateItem(olMailItem)
   
Mois = LCase(Format(Date, "mmmm"))

If Left(Mois, 1) = "a" Or Left(Mois, 1) = "o" Then
Lt = "d'"
Objet = "Rapport du mois " & Lt & Mois

Corp = "Bonjour," & _
vbCrLf & vbCrLf & _
"ci-joint le rapport du mois " & Lt & Mois & " pour votre agence." & _
vbCrLf & vbCrLf & _
"Nous restons bien entendu à votre disposition pour tout renseignement complémentaire." & _
vbCrLf & vbCrLf & _
"Cordialement." & _
vbCrLf & vbCrLf & vbCrLf & _
"Jacky de Fontaineblau - Directeur Général"
Else
Lt = "de"
Objet = "Rapport du mois " & Lt & " " & Mois

Corp = "Bonjour," & _
vbCrLf & vbCrLf & _
"ci-joint le rapport du mois " & Lt & " " & Mois & " pour votre agence." & _
vbCrLf & vbCrLf & _
"Nous restons bien entendu à votre disposition pour tout renseignement complémentaire." & _
vbCrLf & vbCrLf & _
"Cordialement." & _
vbCrLf & vbCrLf & vbCrLf & _
"Jacky de Fontaineblau - Directeur Général"
End If

      With Sheets("Base")
        For Each c In .Range("j2:j19")
          Adr = Replace(Strcc, c.Offset(0, 0).Value & " " & c.Offset(0, 1).Value, "")
        Next c
        End With


With Sheets("Publipostage")
    EnvoisA = .Range("e2") & " " & .Range("b6") & ";"
    AdressBCC = Replace(Adr, EnvoisA, "")
    NomPdf = .Range("b6") & ".pdf"
    'NomDoc = .Range("b6") & ".doc"
End With
   

    Chemin = ThisWorkbook.Path & "\Fichiers pdf\"
    Rep = ThisWorkbook.Path & "\Fichiers doc\"
   
   
    With Msg
    .To = EnvoisA
    .BCC = Mid(AdressBCC, 1, Len(AdressBCC) - 1)
    .Subject = Objet
    .Body = Corp
    .Display
    .Attachments.Add Chemin & NomPdf
    '.Attachments.Add Rep & NomDoc
   End With
        Set OlApp = Nothing
    Set Msg = Nothing
 Next
t = Timer + 1.2: Do Until Timer > t: DoEvents: Loop
        Rep_Pdf = Dir(Chemin & "*.*")
    Do While Rep_Pdf <> ""
        Kill Chemin & Rep_Pdf
        Rep_Pdf = Dir
    Loop
        Rep_Doc = Dir(Rep & "*.*")
    Do While Rep_Doc <> ""
        Kill Rep & Rep_Doc
        Rep_Doc = Dir
    Loop
     With Sheets("Publipostage")
If .Range("n2") = 17 Then
.Range("b2:e6, n2").ClearContents
End
End If
End With
     Next k
Fin:
Exit Sub
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.Quit

'Application.WindowState = xlNormal

End Sub

 

[kiki29]

Re : Publipostage Word et envois pièces jointes Pdf

Salut, qqs conseils :
Décomposer ton code en procédures/fonctions appelées depuis une procédure principale
meilleure lisibilité et évolution/débogage plus faciles.

Utiliser le Late Binding ( pas de références à cocher )
Utiliser le CodeName. L'utilisateur peut renommer les feuilles sans avoir à retoucher au code VBA
Utiliser Smart Indenter

Tout cela éviterait l'aspect salmigondis.

 

[Lone-wolf]

Re : Publipostage Word et envois pièces jointes Pdf

Bonsoir kiki

Désolé pour le retard de la réponse. Je sais que ce serait mieux; mais je n'ai pas assez d'expérience pour tout décomposer et faire un Late Binding.

 

[kiki29]

Salut, l'expérience cela s'acquiert mais apparemment tu ne veux pas progresser.