SendMail CDO

SendMail (CDO)

Envoi de mails avec pièces jointes depuis VBA sous Win2000/XP, en accédant à la couche MAPI via l'interface CDO (Collaboration Data Objects).

Cette méthode doit permettre d'éviter le message de sécurité d'Outlook signalant qu'une application tente d'envoyer un message à notre place.

Sub SendMailCDO()
    'Déclaration précoce ("Early Binding")
    'Cocher la référence à Microsoft CDO for Exchange 2000 librairy
    ' ou Microsoft CDO for Windows 2000 librairy
    Dim Message As New cdo.Message

    With Message
        .From = "moi@domaine.net"
        .To = "destinataire@domaine.com"
        .Subject = "sujet du mail"
        .TextBody = "Le corps du message"
        .AddAttachment ("c:/cheminfichier.ext")
        .GetStream.SaveToFile "C:/MonMail.txt", adSaveCreateOverWrite
        .Send
    End With
    Set Message = Nothing

End Sub

On peut s'affranchir de référencer la bibliothèque avec la syntaxe suivante :

Sub SendMailCDO()
    ' Déclaration tardive ("Late Binding")
    Dim Cdo_Message As Object

    Set Cdo_Message = CreateObject("CDO.Message")

    With Cdo_Message
        .To = "destinataire@domaine.fr"
        .from = """Emetteur"""
        .Subject = "Le Sujet"
        .TextBody = "Le Corps du message"
        .AddAttachment ("c:/cheminfichier.ext")
        .Send
    End With
    Set Cdo_Message = Nothing

End Sub

Si le serveur smtp par défaut n'est pas reconnu (clients mail non Microsoft), on pourra employer les fonctions ci-dessous.

Function SendMailCDO(Sender As String, Receiver As String, _
                      Subject As String, BodyText As String, _
                      Optional Cc As String, Optional Bcc As String)

    Dim Cdo_Message As New CDO.Message
    Set Cdo_Message.Configuration = GetSMTPServerConfig()
    
    With Cdo_Message
        .To = Receiver
        .From = Sender
        .Subject = Subject
        .Cc = Cc
        .Bcc = Bcc
        .TextBody = BodyText
        .send
    End With
    Set Cdo_Message = Nothing

End Function

Function GetSMTPServerConfig() As Object
    Dim Cdo_Config As New CDO.Configuration
    Dim Cdo_Fields As Object
    Set Cdo_Fields = Cdo_Config.Fields

    With Cdo_Fields
        .Item(cdoSendUsingMethod) = cdoSendUsingPort
        .Item(cdoSMTPServer) = "smtp.free.fr"
        .Item(cdoSMTPServerPort) = 25
        .Update
    End With

    Set GetSMTPServerConfig = Cdo_Config
    Set Cdo_Config = Nothing
    Set Cdo_Fields = Nothing

End Function

Syntaxe :

Call SendMailCDO("emetteur@domaine.fr", "destinataire@domaine.com", "sujet", "corps du message")