Option Explicit
Option Compare Text
Sub EnvoiMailCDO()
Dim mMessage As Object
Dim Chemin As String
Dim mConfig As Object
Dim mChps
Dim PJ As String 'Piece-Jointe=OUI/NON
Dim fichier As Variant
Dim CorpsMessage As Variant
Set mConfig = CreateObject("CDO.Configuration")
mConfig.Load -1
Set mChps = mConfig.Fields
With mChps
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'Adapter suivant votre serveur de mail. (exemple pour Gmail.)=> Gmail "gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = [C4].Value
'En principe, 25 fonctionne avec tout les serveurs.
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = [C5].Value
'Vous pouvez essayer sans ces trois lignes
'Mais si votre serveur demande une authentification,
If [C3].Value <> "" Then
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = [C3].Value
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = [C7].Value
End If
'Si votre serveur demande une connexion sûre (SSL)
If [C6].Value <> "Oui" Then
'?????????????
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = "true"
End If
.Update
End With
Set mMessage = CreateObject("CDO.Message")
With mMessage
Set .Configuration = mConfig
.To = [G3].Value
.From = [C3].Value
.To = [G1]
.Subject = [G4].Value
.TextBody = [G6].Value
If Range("G5") = "OUI" Then
Range("G7").Value = Chemin 'et nom complet du fichier
Chemin = Workbooks(ActiveWorkbook.Name).FullName
Chemin = ThisWorkbook.FullName
Range("G7").Value = ThisWorkbook.Path 'Chemin
fichier = Application.GetOpenFilename("Tous les fichiers (*.*),*.*")
' .AddAttachment 'Chemin et nom complet du fichier à joindre
Chemin = Workbooks(ActiveWorkbook.Name).Path
Range("G7").Value = Chemin 'et nom complet du fichier
' .Display
Else
End If
'Ou :
' .Send
End With
Set mMessage = Nothing
'Libère les ressources
Set mConfig = Nothing
Set mChps = Nothing
End Sub
