XL 2013 Envoi mail par macro via exchange

[estivill]

Bonjour à tous,
Tout d'abord je vous remercie de prendre le temps de me lire et de penser à ma problématique.

J'utilisais un fichier excel avec une Macro afin d'envoyer des mails de manière automatique avec l'Application OUTLOOK.
Malheureusement je ne peux plus m'en servir car nos licences ne sont plus valides pour l'application puisque nous utilisons Office 2013 et office 365.

Je dois donc passer par le navigateur et la plateforme exchange pour envoyer mon mail, malgré les infos que j'ai pu glaner impossible de modifier ma macro en conséquence.....
Auriez vous une solution ?


Voici la macro d'envoi :
Sub envoi()
'Cette macro se met en lien avec microsoft exchange installé sur le PC et envoi le mail avec le compte connecté

'déclaration des variables
Dim OutApp As Object
Dim OutMail As Object


derl = Range("A" & Rows.Count).End(xlUp).Row

For i = 4 To derl 'première ligne du tableau

If (ThisWorkbook.Sheets("Suivi réponse").Range("O" & i) <> "") _
And (ThisWorkbook.Sheets("Suivi réponse").Range("P" & i) <> "1") Then 'test de la demande d'envoi dans O et flag en P
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
.To = ThisWorkbook.Sheets("Suivi réponse").Range("J" & i).Value 'Destinataire du mail
'.CC = ThisWorkbook.Sheets("Suivi réponse").Range("B3").Value 'Copie du mail
'.BCC = "" 'Copie caché du mail
.Subject = ThisWorkbook.Sheets("Suivi réponse").Range("M" & i).Value 'Objet du mail
.Body = ThisWorkbook.Sheets("Suivi réponse").Range("N" & i).Value 'Corps du mail

.Send
End With
Range("P" & i).Value = 1 'Flag d'envoi
Range("Q" & i).Value = Now 'Flag d'envoi
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

End If

Next i

'fermer le classeur à la fin
'ThisWorkbook.Close
End Sub

 

[Hasco]

bonjour,

Pour une association, j'avais fait ce module.
Vous verrez que vous aurez à adapter ou à construire différents éléments :
1 - voir la configuration (serveur smtp) suivant votre client mail (ici prévu pour gmail)
2 - destinataire(s), destinataire(s) caché(s)
3 - le corps du mail (format text ou html)
4 - prévoir éventuellement les pièces jointes
etc.

La configuration se fait dans une fonction (GetCdoConfig) autonome, ce qui permet de construire des mails en boucle sans avoir à refaire cette configuration pour chaque mail.

Cordialement

Option Explicit

Private CdoConfig As Object
Private CdoConfigErrorMessage As String

Function GetCdoConfig() As Boolean
    On Error GoTo FIN_CDO_Config

    If CdoConfig Is Nothing Then
        Set CdoConfig = CreateObject("CDO.Configuration")

        CdoConfig.Load -1
        With CdoConfig.Fields
            ' --- configuration des variables CDO pour gmail
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"       ' Adapter
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465

            ' --- authentification ---
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "adresse@gmail.com" ' Adapter
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "motdepasse"        ' Adapter
            ' --- connexion ssl ---
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = "true"
            .Update
        End With
    End If

    ' --- Sortie et gestion des erreurs ---
FIN_CDO_Config:
    If Err.Number <> 0 Then CdoConfigErrorMessage = Err.Description
    On Error GoTo 0

End Function

Sub EnvoiMail(Objet As String, Destinataires As String, Optional Cachés As String = "")
    Dim cdo_msg As Object
    Dim cellule As Range, plage As Range
    Dim Ligne As Long

    'Set plage = ThisWorkbook.Sheets("Messages").Range("A1:A1000")

    '
    ' L'appel à la fonction GetCdoConfig
    ' Vérifiera si la configuration existe déjà
    '
    If GetCdoConfig() Then
        '
        'Commencer la boucle de création et d'envoi de message individuel
        For Each cellule In plage
            Set cdo_msg = CreateObject("CDO.Message")
            With cdo_msg
                Set .Configuration = CdoConfig
                .MimeFormatted = True
                .GetStream.Charset = "utf-8"
                .BodyPart.Charset = "utf-8"
                .BodyPart.ContentTransferEncoding = "base64"

                .To = Destinataires
                If Cachés <> "" Then .BCC = Cachés
                .From = "coco@lariflette.fr"
                .Subject = Objet    ' A construire
                If TextBody <> "" Then .TextBody = TextBody ' A définir et  construire
                If HtmlBody <> "" Then .HtmlBody = HtmlBody ' A définir et construire
                If PieceJointe <> "" Then
                    If Dir(Trim(PieceJointe)) <> "" Then
                        .AddAttachment Trim(PieceJointe) ' A définir
                    Else
                        If MsgBox("Pièce jointe introuvable : " & vbCrLf & PieceJointe & vbCrLf & vbCrLf _
                                & "Envoyer quand même le message ?", vbQuestion + vbYesNo, "Envoyer un message") = vbNo Then
                            GoTo FIN
                        End If
                    End If
                End If

                .Send
            End With
            Set cdo_msg = Nothing
        Next
        '
        ' Destruction de l'objet configuration si il n'a plus lieu d'être
        ' Set CdoConfig = Nothing
    Else
        '
        ' Eventuellement afficher le message
        ' d'erreur de configuration
        MsgBox "Envoi mail interrompu en raison de l'erreur suivante : " & vbCrLf & vbCrLf & _
               CdoConfigErrorMessage, vbExclamation, "Relance personnalisée"
    End If
FIN:
End Sub