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