Scinder envoi email par groupe de 50

[david84]

Bonjour,
Par le biais d'un UserForm, je sélectionne des adresse mails. Celles-ci sont placées dans un contrôle Label nommé "Résultat" (en gras dans le code). Un bouton de commande me permet d'envoyer un mail à l'ensemble des adresses sélectionnées. Cette macro ci-dessous fonctionne correctement. Je cherche maintenant à modifier ce code de manière à ce que s'il y a plus de 50 adresses mail stockées dans "Résultat", l'envoi de ces mails soit scindé par groupe de 50 (par exemple si "Résultat contient 80 adresses mails, la macro procède à l'envoi des 50 1er mails, puis ensuite des 30 autres).
J'ai éventuellement une idée sur la manière de procéder mais celle-ci me semble complexe. Donc avant de me lancer, je me dis qu'il y a peut être une solution simple🙄.
J'ai regardé du côté des membres de l'objet MailItem mais aucune méthode n'a retenu mon attention (peut-être suis-je passé à côté de l'une d'elle...).
Peut-être avez-vous un exemple de boucle à utiliser et à imbriquer dans le code existant ?
Bref, je suis preneur de toute idée ou proposition.
Merci

Private Sub EnvoiMail_Click()
' Thierry (XLD)
Dim OLApplication As Outlook.Application, OLMail As Outlook.MailItem

If ListeMails.ListCount = 0 Then Exit Sub

Set OLApplication = CreateObject("Outlook.Application")
Set OLMail = OLApplication.CreateItem(OLMailItem)

With OLMail
'.To = MailTo ' Destinataire
'.CC = MailCC ' Copie
.BCC = Résultat
.Importance = olImportanceNormal
.Subject = ObjetMessage ' Sujet
.Body = CorpsMessage ' Message
'.Attachments.Add CheminDestination ' Pièce jointe
.Categories = "Daily"
.OriginatorDeliveryReportRequested = True ' Accusé de dépôt
.ReadReceiptRequested = True ' Accusé de lecture
' .Send '<<<<<<<<<<<<<<<Pour envoyer directement
.Display '<<<<<<<<<<<<<Pour voir le mail avant envoi
End With

Set OLApplication = Nothing
Set OLMail = Nothing
Unload Me
Exit Sub
End Sub

 

[tototiti2008]

Re : Scinder envoi email par groupe de 50

Bonjour david,

Que contient ton label ? toutes les adresses séparées par des ";" ?

 

[david84]

Re : Scinder envoi email par groupe de 50

Bonjour Tototiti🙂,

Que contient ton label ? toutes les adresses séparées par des ";" ?

oui tout à fait.
Je t'ai placé un fichier exemple au format .xlsm (c'est du 2007).
Les explications sont dessus.
Merci de ton aide🙂.
A+

 

[david84]

Re : Scinder envoi email par groupe de 50

Re,
en attendant peut-être une solution plus simple, ci-joint celle que j'ai trouvée et qui semble fonctionner. La macro est réglée sur des envois groupés de mails par 5 adresses pour faciliter les tests : elle ouvre un mail contenant au maxi 5 adresses. Ainsi, si vous avez sélectionné 12 adresses 3 mails sont ouverts, 2 contenant chacun 5 adresses et un 3ème contenant 2 adresses.
Si vous avez d'autres idées (autre code, simplification ou amélioration du code existant,...), n'hésitez-pas à m'en faire part.

Private Sub EnvoiMail_Click()
' Thierry (XLD)
Dim OLApplication As Outlook.Application, OLMail As Outlook.MailItem, ListeRésultat

If ListeMails.ListCount = 0 Then Exit Sub

Do

ListeRésultat = Split(Résultat, ";")

Dim TableauRésultat()
ReDim TableauRésultat(0 To UBound(ListeRésultat))
LimiteSup = IIf(UBound(ListeRésultat) > 4, 4, UBound(ListeRésultat))
For i = 0 To LimiteSup
temp = ListeRésultat(i)
Sélection = Sélection & temp & ";"
TableauRésultat(i) = ""
temp = ""

Next i
temp = Résultat
Résultat = Sélection
temp = ""
For j = LBound(ListeRésultat) To UBound(ListeRésultat)
Pos = InStr(Sélection, ListeRésultat(j))
If Pos > 0 Then ListeRésultat(j) = ""
Next j
Sélection = ""

For k = LBound(ListeRésultat) To UBound(ListeRésultat)
If ListeRésultat(k) <> "" Then
temp = ListeRésultat(k) & ";"
Sélection = Sélection & temp
temp = ""

End If
Next k
RésultatSuite = Sélection
Sélection = ""
Set OLApplication = CreateObject("Outlook.Application")
Set OLMail = OLApplication.CreateItem(OLMailItem)

With OLMail
'.To = MailTo ' Destinataire
'.CC = MailCC ' Copie
.BCC = Résultat
.Importance = olImportanceNormal
.Subject = ObjetMessage ' Sujet
.Body = CorpsMessage ' Message
'.Attachments.Add CheminDestination ' Pièce jointe
.Categories = "Daily"
.OriginatorDeliveryReportRequested = True ' Accusé de dépôt
.ReadReceiptRequested = True ' Accusé de lecture
' .Send '<<<<<<<<<<<<<<<Pour envoyer directement
.Display '<<<<<<<<<<<<<Pour voir le mail avant envoi
End With

Résultat = ""
Résultat = RésultatSuite
RésultatSuite = ""
Loop While Résultat <> ""

Set OLApplication = Nothing
Set OLMail = Nothing
Unload Me

Exit Sub
End Sub

A+

 

[tototiti2008]

Re : Scinder envoi email par groupe de 50

Bonjour david,

désolé, un peu occupé aujourd'hui...

une proposition (même si la tienne semble fonctionner correctement) :

Private Sub EnvoiMail_Click()
' Thierry (XLD)
Dim OLApplication As Outlook.Application, OLMail As Outlook.MailItem, ListeRésultat
Dim TableauRésultat, NbGrp As Long, i As Long, TableauGrp, j as long
Const MaxAdr = 50
    Résultat = Range("A1")
    If ListeMails.ListCount = 0 Then Exit Sub
    
    ListeRésultat = Split(Résultat, ";")
    NbGrp = Application.RoundUp((UBound(ListeRésultat) + 1) / MaxAdr, 0)
    
    Set OLApplication = CreateObject("Outlook.Application")
    
    For i = NbGrp To 1 Step -1
        Résultat = ""
        For j = (i - 1) * MaxAdr To i * MaxAdr - 1
            If j > UBound(ListeRésultat) Then Exit For
            Résultat = Résultat & ";" & ListeRésultat(j)
        Next j
        If Len(Résultat) > 0 Then Résultat = Right(Résultat, Len(Résultat) - 1)
        Set OLMail = OLApplication.CreateItem(OLMailItem)
        
        With OLMail
            '.To = MailTo ' Destinataire
            '.CC = MailCC ' Copie
            .BCC = Résultat
            .Importance = olImportanceNormal
            .Subject = ObjetMessage ' Sujet
            .Body = CorpsMessage ' Message
            '.Attachments.Add CheminDestination ' Pièce jointe
            .Categories = "Daily"
            .OriginatorDeliveryReportRequested = True ' Accusé de dépôt
            .ReadReceiptRequested = True ' Accusé de lecture
            ' .Send '<<<<<<<<<<<<<<<Pour envoyer directement
            .Display '<<<<<<<<<<<<<Pour voir le mail avant envoi
        End With
        
    Next i
    
    Set OLApplication = Nothing
    Set OLMail = Nothing
    Unload Me
End Sub

 

[Softmama]

Re : Scinder envoi email par groupe de 50

Hello tlm

J'allais m'y mettre, mais j'ai la même proposition que tototiti à formuler. En effet, si les listes sont séparées par des ";", la méthode du split et du tableau me semble la plus simple.

 

[david84]

Re : Scinder envoi email par groupe de 50

Re Tototiti, bonjour Softmama,

Comme ton code ne fonctionnait pas en l'état, je me suis permis de retoucher les parties en gras. J'ai également modifié la constante MaxAdr à 5 pour tester plus facilement.
Après avoir enlevé le "Résultat = Range("A1")" (je pense que tu t'en es servi pour des tests), ton code fonctionnait sauf que si jamais je sélectionnais un multiple de 5, il m'ouvrait un mail sans aucune adresse en plus des autres mails (ex sur le fichier : sélection d'aéronautique, athlétisme et basket, soit 10 adresses mails => ouverture de 3 mails dont le 3ème vide). C'est pour cela que j'ai enlevé le "+1" de

NbGrp = Application.RoundUp((UBound(ListeRésultat) + 1) / MaxAdr, 0)

et cela semble fonctionner correctement.
Concernant ton code, je le trouve très instructif : se servir d'une constante pour caler le nombre de mails par groupe, franchement je n'y avais pas pensé😕.
Ensuite, la manière dont tu traites les données donne un code plus compact (c'est là où l'on voit la dextérité😱).
Bravo donc et merci encore.
Merci également à Softmama dont j'apprécie la lecture de ses codes🙂.
A+

NB Tototiti : pour info, j'ai voulu t'envoyer un MP mais ta boîte est pleine🙄 !

Private Sub EnvoiMail_Click()
' Thierry (XLD)
Dim OLApplication As Outlook.Application, OLMail As Outlook.MailItem, ListeRésultat
Dim TableauRésultat, NbGrp As Long, i As Long, TableauGrp, j As Long
Const MaxAdr = 5 'j'ai placé le nbre de mails à 5 pour tester
'Résultat = Range("A1") 'je pense que tu t'en es servi pour tes tests
If ListeMails.ListCount = 0 Then Exit Sub

ListeRésultat = Split(Résultat, ";")
'NbGrp = Application.RoundUp((UBound(ListeRésultat) + 1) / MaxAdr, 0)
NbGrp = Application.RoundUp((UBound(ListeRésultat)) / MaxAdr, 0)
Set OLApplication = CreateObject("Outlook.Application")

For i = NbGrp To 1 Step -1
Résultat = ""
For j = (i - 1) * MaxAdr To i * MaxAdr - 1
If j > UBound(ListeRésultat) Then Exit For
Résultat = Résultat & ";" & ListeRésultat(j)
Next j
If Len(Résultat) > 0 Then Résultat = Right(Résultat, Len(Résultat) - 1)
Set OLMail = OLApplication.CreateItem(OLMailItem)

With OLMail
'.To = MailTo ' Destinataire
'.CC = MailCC ' Copie
.BCC = Résultat
.Importance = olImportanceNormal
.Subject = ObjetMessage ' Sujet
.Body = CorpsMessage ' Message
'.Attachments.Add CheminDestination ' Pièce jointe
.Categories = "Daily"
.OriginatorDeliveryReportRequested = True ' Accusé de dépôt
.ReadReceiptRequested = True ' Accusé de lecture
' .Send '<<<<<<<<<<<<<<<Pour envoyer directement
.Display '<<<<<<<<<<<<<Pour voir le mail avant envoi
End With

Next i

Set OLApplication = Nothing
Set OLMail = Nothing
Unload Me
End Sub

 

[tototiti2008]

Re : Scinder envoi email par groupe de 50

Bonjour Softmama,
Re,

Après avoir enlevé le "Résultat = Range("A1")" (je pense que tu t'en es servi pour des tests)

Oups, désolé... il faut savoir que je n'ai pas outlook, donc je ne peux pas faire tourner le code dans son intégralité, en effet c'est un reste de test.

NbGrp = Application.RoundUp((UBound(ListeRésultat)) / MaxAdr, 0)

Bizarre, chez moi ça fonctionne bien avec le +1
si tu mets 11 adresses par exemple, il te fait 2 ou 3 mails ?

Merci pour les MP, j'avais pas remarqué...

 

[david84]

Re : Scinder envoi email par groupe de 50

Re

si tu mets 11 adresses par exemple, il te fait 2 ou 3 mails ?

Il me fait 3 mails : 2 de 5 adresses et un de une adresse.
A+

 

[tototiti2008]

Re : Scinder envoi email par groupe de 50

Re,

ça y est, j'ai compris : moi je faisait mes tests sans ";" derrière la dernière adresse et toi tu as un ";"