Gerer les envois Outlook

[Lone-wolf]

Bonjour à toutes et à tous

Je remet le code pour l'envois en masse avec fichier joint Pdf.

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 olMail As MailItem
    Dim EnvoisA$, Objet$, Corp$, Mois$, NomPdf$, NomDoc$, Rep_Pdf$, Msg$, _
    Rep_Doc$, Rep$, Chemin$, Lt$, CopieC$, AdressBCC$, Adr$, c As Range
   
    Set OlApp = New Outlook.Application
    Set olMail = 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, 7).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 olMail
    .To = EnvoisA
    .BCC = Mid(AdressBCC, 1, Len(AdressBCC) - 1)
    .Subject = Objet
    .Body = Corp
    .Display
    .Attachments.Add Chemin & NomPdf
    '.Attachments.Add Rep & NomDoc
   End With
       Application.DisplayAlerts = False
        Application.Wait (Now + TimeValue("00:00:07"))
         olMail.Close olSave
        OlApp.Quit
        Set OlApp = Nothing
        Set olMail = Nothing
 Next
        With Sheets("Publipostage")
If .Range("n2") = 17 Then
.Range("b2:e6, n2").ClearContents
End If
End With

Application.WindowState = xlNormal
  Msg = MsgBox("Voulez-vous poursuivre les envois ?", vbYesNo, "MESSAGERIE")
 If Msg = vbNo Then
         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
    Exit Sub
 Else
 'Call Envois_Suite
 End If
t = Timer + 1.2: Do Until Timer > t: DoEvents: Loop
     Next k
Fin:
Exit Sub

End Sub

D'après ce que j'ai pu voir sur le net, on ne peut qu'envoyer 50 mails maximum à la fois. J'aimerais qu'après le message en cliquant sur Oui, je puisse continuer l'envois pour les 50 autres personnes sans (si possible), créer une nouvelle macro.