Sub DIFFUSION()
Dim Répertoire As String, _
Fichier As String, _
feuille As Variant, _
Nom As Name
Dim ol As Object, myitem As Object
Dim Listdest As String
Dim test As String
If MsgBox("Envoyer votre formulaire à " & Sheets("Selection").Range("b4").Value, vbYesNo, "ENVOI MAIL") = vbYes Then
'Création du PDF
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Répertoire = "c:\Temp\" 'Chemin à préciser
With ActiveSheet
Fichier = "Formulaire de " & ThisWorkbook.Worksheets("Selection").Range("b2") & ".pdf" 'Nom de fichier a adapter
.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Répertoire & Fichier, _
Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End With
Application.DisplayAlerts = True
'Création du mail'
Set ol = CreateObject("outlook.application")
Set myitem = ol.CreateItem(olMailItem)
Listdest = Application.VLookup(Sheets("selection").Range("b4"), Sheets("agents").Range("a1:c100"), 3, False)
myitem.to = Listdest
myitem.Subject = "Formulaire de " & ThisWorkbook.Worksheets("Selection").Range("b2") 'Titre du Mail a adapter
myitem.BodyFormat = olFormatHTML
' Corps du mail a adapter
myitem.HTMLBody = "<HTML>Bonjour,<p>" & Chr(10) & Chr(10) _
& "Veuillez trouver ci-joint le formulaire de " & ThisWorkbook.Worksheets("Selection").Range("b2") & "</b><p>" _
& "Bonne réception.</HTML>"
myitem.Attachments.Add Répertoire & Fichier
myitem.Display
Set ol = Nothing
Else
End If
End Sub