Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Gerer les envois Outlook

Lone-wolf

XLDnaute Barbatruc
Bonjour à toutes et à tous

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

Code:
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.
 
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…