Private Sub EnvoiCdo()
'===================================================
' INIT ICI LES PARAMETRES .
'---------------------------------------------------
'si plusieurs adresses séparer avec un point virgule
AdresExpediteur$ = ""
LesAdresDestinataires$ = "" 'ici une ou plusieurs séparer avec un point virgule
LesAdresDestinatairesCC$ = ""
LesAdresDestinatairesBCC$ = ""
Sujet$ = "ici voir le sujet ......."
Message$ = "ici voir le message ..."
PathFichier$ = "" 'ici chemin et fichier à joindre
'
cdoSendUsingPort = 2
SMTPServeurPort = 25
SMTPServeur$ = "smtp.lagoon.nc" 'exp "smtp.orange.fr"
ID_Connexion$ = "" 'pas obligé selon essai !?
MP_Connexion$ = "" 'pas obligé selon essai !?
'******************************************************
'déclaration tardive sans Ref.CDO (sans aide contextuel)
On Error GoTo ErreurNET: Err.Clear
Dim CdoMsg As Object
Set CdoMsg = CreateObject("cdo.message")
'---------- config SMTPServer
With CdoMsg.Configuration.Fields
'Paramétrage du serveur SMTP externe
'(en interne inutile, mais souvent erreur"Valeur de configuration SendUsing non valide")
'# le minimum ------
'Config mode d'envoi:(CdoSendUsingPort(2) externe envoi direct) (CdoSendUsingPickup(1) interne utiliser un dossier local SMTP)
'Numéro Server Port :(smtpserverport mettre 25(par defaut) 465/587 selon serveur!)
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServeur$
If SMTPServeurPort > 0 Then .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPServeurPort
'#------------------
' non obligatore !?
'Authentification:(0)CdoAnonymous (1)CdoBasic (2)CdoNTLM si le serveur en demande une
Xauthentiticate = cdoAnonymous: If ID_Connexion$ > "" And MP_Connexion$ > "" Then Xauthenticate = cdoBasic
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = Xauthenticate
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = ID_Connexion$
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = MP_Connexion$
'Connexion(SSL): True=Utilisation SSL False=Pas d'utilisation SSL(par défaut) si le serveur en demande une sinon false
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10 'sec délai de connexion
.Update
End With
With CdoMsg
'format police si Ref'Microsoft CDO for windows 2000 library'
If FsiReferenceCdoActive Then
.MimeFormatted = True
.GetStream.Charset = cdoISO_8859_15
.BodyPart.Charset = cdoISO_8859_15
.BodyPart.ContentTransferEncoding = "base64"
End If
.From = "<" & AdresExpediteur$ & ">" 'adres.expéditeur
.To = LesAdresDestinataires$ 'adres.destinataire(s)
.CC = LesAdresDestinatairesCC$ 'Cc (Copie carbone) on voit toutes les adres
.BCC = LesAdresDestinatairesBCC$ 'Bcc (Copie carbone cachée) on ne voit pas les adres
.Subject = Sujet$
'.HTMLBody = MsgHTMLBody ' < si message html
.TextBody = Message$ 'sinon corps du message en format brut
If PathFichier$ > "" Then .AddAttachment PathFichier$
.Send 'envoi
DoEvents
End With
Set CdoMsg = Nothing
Exit Sub
ErreurNET: 'traite erreur connexion
Msg$ = "Erreur " & Err.Source & " No " & Err.Number & vbLf & vbLf & Err.Description
T$ = "Envoi Mail: Problème de connexion !?"
MsgBox Msg$, vbCritical, T$, Err.HelpFile, Err.HelpContext
Set CdoMsg = Nothing
On Error GoTo 0: Err.Clear
End Sub
Private Function FsiReferenceCdoActive() As Boolean
Dim I%
FsiReferenceCdoActive = False
For I = 1 To ThisWorkbook.VBProject.References.Count
If ThisWorkbook.VBProject.References(I).Name = "CDO" Then FsiReferenceCdoActive = True: Exit Function
Next
End Function