Problème avec boucles For i et For each

[Lone-wolf]

Bonjour à toutes et à tous

J'ai un souci concernant les boucles pour l'envois de mails en BCC. À chaque envois, les adresses sont introduites à la suite, ce qui ne devrait pas être; et je ne sais pas comment faire en sorte pour que les données soient copiées une seule fois sans tenir compte de la première adresse d'envois.

 

[thebenoit59]

Re : Problème avec boucles For i et For each

Salut Love-Wolf.
Souhaites-tu envoyer le mail avec le fichier modifié et ensuite boucler pour chaque adresse ?
Ou ai-je mal interprété ta demande ?

 

[Lone-wolf]

Re : Problème avec boucles For i et For each

Bonsoir thebenoit

Désolé pour le retard. Je ne comprend pas trop ta question.

Si tu veux, ce que j'aimerais c'est ceci:

Je crée le doc + pdf pour toto; j'envois le mail avec fichier .pdf à toto et en BCC le reste des adresses -toto.
Je recrée les fichiers pour tata; j'envois le mail à tata avec fichier .pdf et en BCC le reste des adresses -toto et tata pusique je l'ai déjà envoyé. Je recrée les fichiers pour titi; j'envois le mail avec fichier .pdf et en BCC le reste des adresses -toto -tata et -titi etc.

J'éspère que c'est plus clair.


À bientôt

 

[chris]

Re : Problème avec boucles For i et For each

Bonjour

Remarque : quel est l'intérêt de mettre tout le monde en BBC de tout le monde ? Auntant faire une copie standard...

Je créerais au départ la chaîne contenant toutes les adresses destinataires séparées par un ;

Puis une boucle qui prend tour à tour chaque "destinataire principal", copie la chaîne des "destinataires en copie" en en soustrayant via une fonction REPLACE, le destinataire principal.

 

[Lone-wolf]

Re : Problème avec boucles For i et For each

Bonjour Chris et merci d'avoir répondu.

D'après ce que tu dit, si j'ai bien compris, c'est ce que fait la macro mais sans l'ajout de Replace.

  With Sheets("Publipostage")
  PremAdresse = .Range("e2") & " " & .Range("b6") & ";"
  End With
  
With Sheets("Base") 'Nom complet  et adresse mail
  For Each cel In .Range("a2:a18")
                                'Nom complet  et adresse mail
    Strcc = Strcc & cel.Offset(0, 0).Value & " " & cel.Offset(0, 7).Value & ";"
  Next cel
    CopieC = Split(Strcc, ";")
   
    For i = 0 To UBound(CopieC) - 1
        If CopieC(i) = AdressBCC Then
        Exit For
        Else
            AdressBCC = AdressBCC & CopieC(i) & ";"
        End If
    Next i
        End With

With Msg
    .To = PremAdresse
    .BCC = Mid(AdressBCC, 1, Len(AdressBCC) - 1)
    .Subject = Objet
    .Body = Corp
    .Display
End With

Les 2 problèmes, encore une fois, c'est que, non seulement elle ajoute le premier destinataire, mais elle ajoute à la suite le reste des destinataires.

 

[thebenoit59]

Re : Problème avec boucles For i et For each

Bonjour Lone-Wolf, Chris.

Alors, je pense que ton soucis vient de strcc. En effet avec la boucle, il faudrait remettre strcc = "" pour éviter ce soucis :
strcc = strcc &, où tu récupéreras les adresse mails de la précédente boucle.

 

[Lone-wolf]

Re : Problème avec boucles For i et For each

Bonjour thebenoit,

j'ai placé Strcc = "" à différents endroits mais, ou elle n'est pas prise en considération oubien la macro s'arrête à la première adresse et bloque les copies Word.

 

[chris]

Re : Problème avec boucles For i et For each

Bonjour

je n'avais pas regardé le code. Pas testé tout mais ceci devrait marcher

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

    'Application.WindowState = xlMinimized
    On Error Resume Next
    lig = 1
    
    With Sheets("Base")
        For Each cel In .Range("a2:a18")
                                      'Nom complet  et adresse mail
          Strcc = Strcc & cel.Offset(0, 0).Value & "<" & cel.Offset(0, 7).Value & ">" & ";"
        Next cel
    End With

    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 As String
    Dim c As Range, i As Long
    Dim CopieC, AdressBCC
    
    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")
    EnvoisA = .Range("a2") & "<" & .Range("h2") & ">" & ";"
    AdressBCC = Replace(Strcc, EnvoisA, "")
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
    NomPdf = Feuil2.Range("b6") & ".pdf"
    'NomDoc = c.Offset(0, 0).Value & ".doc"
    .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
Application.DisplayAlerts = False
ActiveWorkbook.Save
Application.Quit

On Error GoTo 0
'Application.WindowState = xlNormal

End Sub

A noter que tes déclarations ne sont pas bonnes il faut préciser le type pour chaque variable "Dim machin as string, truc as string" et non "Dim machin, truc as string" : je n'ai pas corrigé.

 

[thebenoit59]

Re : Problème avec boucles For i et For each

J'ai essayé d'alléger un peu le code, je bloque juste sur le fait que Word conserve une tâche en fond et donc ne se quitte pas ..

Option Explicit

Sub Envois_Publipostage()
Dim titre, nom, prenom, adresse, cp, ville, civilite, _
AdrMail, Nom_doc, Nom_pdf, Fichier, nomcomplet As String
Dim ShPubli As Worksheet, ShBase As Worksheet, Wk As Workbook
Dim lig, j, num As Integer, t
Dim WrdApp As Word.Application, doc As Word.Document

Set Wk = ThisWorkbook
Set ShPubli = Wk.Sheets("Publipostage")
Set ShBase = Wk.Sheets("Base")

    'Application.WindowState = xlMinimized
    'On Error Resume Next
    
    For lig = 2 To 18
    
    With ShBase
        nomcomplet = .Cells(lig, 1)
        titre = .Cells(lig, 2)
        prenom = .Cells(lig, 3)
        nom = .Cells(lig, 4)
        adresse = .Cells(lig, 5)
        cp = .Cells(lig, 6)
        ville = .Cells(lig, 7)
        civilite = .Cells(lig, 2)
        AdrMail = .Cells(lig, 8)
    End With

    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: Exit Sub
   
   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
    
    'Enregistrement Word
    Nom_doc = ThisWorkbook.Path & "\Fichiers doc\" & AdrMail & ".doc"
    doc.SaveAs Nom_doc
    
    'Enregistrement PDF
    doc.ExportAsFixedFormat OutputFileName:=ThisWorkbook.Path & "\Fichiers pdf\" & AdrMail & ".pdf", ExportFormat:=wdExportFormatPDF
    Nom_pdf = ThisWorkbook.Path & "\Fichiers pdf\" & AdrMail & ".pdf"
    
    'Quitter Word
    WrdApp.Quit
    Set doc = Nothing
    Set WrdApp = Nothing

    'partie Outlook
    Dim OlApp As Outlook.Application
    Dim Msg As MailItem
    Dim EnvoisA, Objet, Corp, Mois, NomPdf, NomDoc, Strcc, Rep_Pdf, Rep_Doc, Rep, Chemin, Lt As String
    Dim cel, c As Range, i As Long
    Dim CopieC, AdressBCC
    
    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'"
        Else: Lt = "de"
    End If
    
    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"

    EnvoisA = nomcomplet & "<" & AdrMail & ">" & ";"
    
    With ShBase
        Strcc = "": AdressBCC = ""
        For j = lig + 1 To 18
            'Nom complet  et adresse mail
            Strcc = Strcc & .Cells(j, 1).Value & "<" & .Cells(j, 8).Value & ">" & ";"
        Next j
        
        CopieC = Split(Strcc, ";")
        
        For i = 0 To UBound(CopieC) - 1
            If CopieC(i) = AdressBCC Then
                Exit For
                Else: AdressBCC = AdressBCC & CopieC(i) & ";"
            End If
        Next i
    End With

    Chemin = ThisWorkbook.Path & "\Fichiers pdf\"
    Rep = ThisWorkbook.Path & "\Fichiers doc\"
    
    
    With Msg
        .To = EnvoisA
        .BCC = AdressBCC
        '.BCC = Mid(AdressBCC, 1, Len(AdressBCC) - 1)
        .Subject = Objet
        .Body = Corp
        .Display
        NomPdf = AdrMail & ".pdf"
        'NomDoc = c.Offset(0, 0).Value & ".doc"
        .Attachments.Add Chemin & NomPdf
        '.Attachments.Add Rep & NomDoc
    End With
Next lig

ShPubli.[n2].ClearContents

    Set OlApp = Nothing
    Set Msg = Nothing
        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

Wk.Close True
Application.Quit

'On Error GoTo 0
'Application.WindowState = xlNormal

End Sub

 

[Lone-wolf]

Re : Problème avec boucles For i et For each

Re Chris, thebenoit

@Chris: j'ai déclarer chaqune des variables comme tu l'as dit. La macro ne fait plus de copier-coller à la suite, mais continue à rajouter la première adresse.

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:a18")
          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$
   
    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("Publipostage")
    EnvoisA = .Range("e2") & " " & .Range("b6") & ";"
    AdressBCC = Replace(Strcc, 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

 

[chris]

Re : Problème avec boucles For i et For each

RE

C'est sans doute cette ligne " EnvoisA = .Range("a2") & "<" & .Range("h2") & ">" & ";"
qui prend en dur la ligne 2 au lieu de la ligne lig
mettre

EnvoisA = .Range("a" & lig) & "<" & .Range("h" & lig) & ">" & ";"

 

[Lone-wolf]

Re : Problème avec boucles For i et For each

Bonsoir à tous,

je pense avoir touver la solution, voici la macro au complet et le fichier où j'ai rajouter des colonnes supplémentaires pour les noms et les adresses mails. Si on peux améliorer la macro, toute idée est la bienvenue.

la solution est de faire un 2ème remplacement par rapport à Strcc. J'ai rajouté une cellule complémentaire, parce que bizaremment la dernière adresse n'était pas prise en compte.

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

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