' Utilisation de la méthode CDO : Collaboration Data ObjectsSub CDO_EnvoiMail_AvecPieceJointe()
Dim sPath As String, sFic As String
Dim Flds As Object, iConf As Object, iMsg As Object
' Initialisation des variables
sPath = ActiveWorkbook.Path & "\"
sFic = "Bon de préparation pour chantier.pdf"
' Dim Flds As Variant
If MsgBox("Êtes vous sur de vouloir envoyer le bon de préparation par email au format PDF ?", _
vbQuestion + vbYesNo, "ENVOYER LE BON DE PREPARATION ...") = vbNo Then Exit Sub
'création de la feuille au format pdf
'on cré le fichier PDF dans le même dossier que le fichier source
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath & sFic, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
' Désactiver l'écran et les évènements
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
' Créer la configuration d'envoi des mails
Set iConf = CreateObject("CDO.Configuration")
iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields
With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'cdoBasic
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "Adresse mail complète"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "Mot de passe messagerie" ' Ne doit pas servir !?
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp du fournisseur d'accès"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With
' Création du message avec pièce jointe
Set iMsg = CreateObject("CDO.Message")
With iMsg
Set .Configuration = iConf
.To = "destinataire@free.fr"
.From = """Moi"" <BrunoM45@something.fr>"
.Subject = "Ceci est l'objet du message"
.AddAttachment sPath & sFic ' Attachement du fichier
.TextBody = "Texte du corps du message" & vbNewLine _
& "Ligne 2"
.Send
End With
Set iMsg = Nothing
' On supprime ensuite, si on le souhaite, le fichier
Kill sPath & sFic
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub