Option Explicit
Public titre, nom, prenom, adresse, cp, ville, civilite, adrMail, chDoc, corps, PremAdresse, _
chemin, NomDoc, nom_doc, chPdf, NomPdf, nom_pdf, fichier, rep, chem, Fch1, Fch2, nf, lt As String
Public x, i As Long, cel As Range, c As Range, t
Sub Envois_Pdf()
Dim oApp As Word.Application, doc As Word.Document
On Error Resume Next
nf = ThisWorkbook.Path & "\Modele.doc"
Set oApp = CreateObject("Word.Application")
oApp.Visible = False
Set doc = oApp.Documents.Open(nf)
If Err <> 0 Then
MsgBox "Le fichier doit être dans " & ThisWorkbook.Path, , "Envois PDF"
Exit Sub
End If
With Feuil3
x = 1
For i = 1 To 5
x = x + 1
titre = .Cells(x, 2)
prenom = .Cells(x, 3)
nom = .Cells(x, 4)
adresse = .Cells(x, 5)
cp = .Cells(x, 6)
ville = .Cells(x, 7)
civilite = .Cells(x, 2)
adrMail = .Cells(x, 8)
NomPdf = .Cells(x, 1) & ".pdf"
With doc
.Bookmarks("titre").Range.Text = titre
.Bookmarks("prenom").Range.Text = prenom
.Bookmarks("nom").Range.Text = nom
.Bookmarks("adresse").Range.Text = adresse
.Bookmarks("cp").Range.Text = cp
.Bookmarks("ville").Range.Text = ville
.Bookmarks("civilite").Range.Text = civilite & ","
End With
nom_doc = prenom & " " & nom
doc.SaveAs ThisWorkbook.Path & "\Fichiers doc\" & nom_doc & ".doc"
doc.ExportAsFixedFormat OutputFileName:= _
ThisWorkbook.Path & "\Fichiers pdf\" & nom_doc, ExportFormat:=wdExportFormatPDF
nom_pdf = ThisWorkbook.Path & "\Fichiers pdf\" & nom_doc & ".pdf"
Application.WindowState = xlMinimized
t = Timer + 1: Do Until Timer > t: DoEvents: Loop
Next i
oApp.Quit
End With
Dim OlApp As Outlook.Application
Dim Msg As MailItem
Dim Objet, Corp, Mois, Strcc, Stf As String
Dim CopieC, AdressMailBCC
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
Corps = "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 & _
"Bearn in USA - Directeur Général"
Else
lt = "de"
Objet = "Rapport du mois " & lt & " " & Mois
Corps = "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 & _
"Bearn in USA - Directeur Général"
End If
With Feuil3
PremAdresse = .Range("a2") & "<" & .Range("h2") & ">" & ";"
End With
With Feuil3 'Nom complet et adresse mail
For Each cel In .Range("a3:a6")
'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) = AdressMailBCC Then
Exit For
Else
AdressMailBCC = AdressMailBCC & CopieC(i) & ";"
End If
Next i
End With
Chemin = ThisWorkbook.Path & "\Fichiers pdf\"
rep = ThisWorkbook.Path & "\Fichiers doc\"
With Msg
.To = PremAdresse
.CC = Mid(AdressMailBCC, 1, Len(AdressMailBCC) - 1)
.Subject = Objet
.Body = Corps
.Display
For Each c In Feuil3.Range("i2:i6")
fichier = c.Offset(0, 0).Value
NomDoc = c.Offset(0, 0).Value & ".doc"
.Attachments.Add Chemin & fichier
Next c
End With
Set OlApp = Nothing
Set Msg = Nothing
Fch1 = Dir(chemin & "*.*")
Do While Fch1 <> ""
Kill chemin & Fch1
Fch1 = Dir
Loop
Fch2 = Dir(rep & "*.*")
Do While Fch2 <> ""
Kill rep & Fch2
Fch2 = Dir
Loop
On Error GoTo 0 ' Annule la gestion d'erreur
End Sub