Envoyer mail à plusieurs destinataires avec case à cocher

VALENTIN -  
MIMOHUGUES Messages postés 4 Date d'inscription   Statut Membre Dernière intervention   -
Bonjour, je suis dans une impasse.... je veux envoyer automatiquement des mails en cochant des cases à cocher qui seraient liaient avec des adresses mail, cela marche que pour une case, le reste le code ne les prends pas !

voici mon code:
Public Sub EnvoiAutomatiqueMail()
If MsgBox("Souhaitez-vous envoyer ce mail ?", vbQuestion + vbYesNo, "ENVOIE MAIL") = vbYes Then

Dim OutlookApp As Object
Dim OutlookMail As Object
Dim adresse As String
Dim message As String
Dim sujet As String
Dim ENGIE1 As String
Dim GRT1 As String
Dim TELMMA1 As String
Dim PCS1 As String
Dim MULTITECH1 As String
Dim IBM1 As String

sujet = " Intérvention EUROPE AVENUE "


If IBM Then
IBM1 = Range("D63,D64,D65,D66")
End If

If ENGIE Then
ENGIE1 = Range("E63,E64,E65,E66")
End If

If GRT Then
GRT1 = Range("F63,F64,F65,F66")
End If

If TELMMA Then
TELMMA1 = Range("A63,A64,A65,A66")
End If

If PCS Then
PCS1 = Range("B63,B64,B65,B66")
End If

If MULTITECH Then
MULTITECH1 = Range("C63,C64,C65,C66")
End If

ActiveWorkbook.SendMail Recipients:=Array("IBM1", "TELMMA1")
ActiveWorkbook.Close
adresse = Array("IBM1", "TELMMA1")
message = "Boujour" & " " & Range("CT44") & vbCrLf & vbCrLf & "Bienvenue sur les tests" & vbCrLf & vbCrLf & "SIGNATURE"
Set OutlookApp = CreateObject("outlook.application")
Set OutlookMail = OutlookApp.CreateItem(0)
With OutlookMail

.Subject = sujet
.To = adresse
.Body = message
.Send

End With
End If
End Sub

2 réponses

Réponse 1 / 2
thev Messages postés 1986 Date d'inscription   Statut Membre Dernière intervention   713
  
        
    'Assignation de l'application Outlook :
    Set OutlookApp = CreateObject("outlook.application") 
    
    ' Assignation des objets Outlook :
    Set OutlookMail =  OutlookApp .CreateItem(olMailItem)
 
    ' remplissage destinataires "A"
     destinataire = Array("IBM1", "TELMMA1") 
     For i_destinataire = 0 To UBound(destinataire)
            Set dest_A = OutlookMail.Recipients.Add(destinataire(i_destinataire))
            dest_A.Type = olTo
     Next i_destinataire
       
    'remplissage sujet et objet
    OutlookMail.Subject = sujet 
    OutlookMail.Body =  message

    'envoie le message
    OutlookMail.Send

  
0
MIMOHUGUES Messages postés 4 Date d'inscription   Statut Membre Dernière intervention  
 
merci de ton intervention, mais ca ne marche pas ...
0
thev Messages postés 1986 Date d'inscription   Statut Membre Dernière intervention   713 > MIMOHUGUES Messages postés 4 Date d'inscription   Statut Membre Dernière intervention  
 
Je vois une erreur 

 ' Assignation des objets Outlook :
    Set OutlookMail =  OutlookApp.CreateItem(olMailItem)
0
MIMOHUGUES Messages postés 4 Date d'inscription   Statut Membre Dernière intervention  
 
oui je l'avais corrigé, je vous remet le code :

Public Sub EnvoiAutomatiqueMail()
If MsgBox("Souhaitez-vous envoyer ce mail ?", vbQuestion + vbYesNo, "ENVOIE MAIL") = vbYes Then

Dim OutlookApp As Object
Dim OutlookMail As Object
Dim adresse As String
Dim message As String
Dim sujet As String
Dim ENGIE1 As String
Dim GRT1 As String
Dim TELMMA1 As String
Dim PCS1 As String
Dim MULTITECH1 As String
Dim IBM1 As String

If IBM Then
IBM1 = Range("D63,D64,D65,D66")
End If

If ENGIE Then
ENGIE1 = Range("E63,E64,E65,E66")
End If

If GRT Then
GRT1 = Range("F63,F64,F65,F66")
End If

If TELMMA Then
TELMMA1 = Range("A63,A64,A65,A66")
End If

If PCS Then
PCS1 = Range("B63,B64,B65,B66")
End If

If MULTITECH Then
MULTITECH1 = Range("C63,C64,C65,C66")
End If


sujet = " Intérvention EUROPE AVENUE "
message = "Boujour" & " " & Range("CT44") & vbCrLf & vbCrLf & "Bienvenue sur les tests" & vbCrLf & vbCrLf & "SIGNATURE"
adresse = IBM1 & ENGIE1 & GRT1 & TELMMA1 & PCS1 & MULTITECH1

With OutlookMail

'remplissage sujet et objet
OutlookMail.Subject = sujet
OutlookMail.To = adresse
OutlookMail.Body = message

'envoie le message
OutlookMail.Send
End With
End If
End Sub

mon problème est au niveau de "adresse", j'aimerais qu'il prenne les informations de toute les cellules que j'ai renseigné.
0
Réponse 2 / 2
thev Messages postés 1986 Date d'inscription   Statut Membre Dernière intervention   713
  
 

Public Sub EnvoiAutomatiqueMail()
 
 If MsgBox("Souhaitez-vous envoyer ce mail ?", vbQuestion + vbYesNo, "ENVOIE MAIL") = vbYes Then

     Dim OutlookApp As Object
     Dim OutlookMail As Object
     Dim adresse As String
     Dim adresses()
     Dim message As String
     Dim sujet As String
     Dim destinataires As Range
         
     If IBM Then
        If destinataires Is Nothing Then
            Set destinataires = Range("D63,D64,D65,D66")
        Else
            Set destinataires = Union(destinataires, Range("D63,D64,D65,D66"))
        End If
     End If
     If ENGIE Then
        If destinataires Is Nothing Then
            Set destinataires = Range("E63,E64,E65,E66")
        Else
            Set destinataires = Union(destinataires, Range("E63,E64,E65,E66"))
        End If
     End If
     If GRT Then
        If destinataires Is Nothing Then
            Set destinataires = Range("F63,F64,F65,F66")
        Else
            Set destinataires = Union(destinataires, Range("F63,F64,F65,F66"))
        End If
     End If
     If TELMMA Then
        If destinataires Is Nothing Then
            Set destinataires = Range("A63,A64,A65,A66")
        Else
            Set destinataires = Union(destinataires, Range("A63,A64,A65,A66"))
        End If
     End If
     If PCS Then
        If destinataires Is Nothing Then
            Set destinataires = Range("B63,B64,B65,B66")
        Else
            Set destinataires = Union(destinataires, Range("B63,B64,B65,B66"))
        End If
     End If
     If MULTITECH Then
         If destinataires Is Nothing Then
            Set destinataires = Range("C63,C64,C65,C66")
        Else
            Set destinataires = Union(destinataires, Range("C63,C64,C65,C66"))
        End If
     End If
     
     sujet = " Intervention EUROPE AVENUE "
     message = "Bonjour" & " " & Range("CT44") & vbCrLf & vbCrLf & "Bienvenue sur les tests" & vbCrLf & vbCrLf & "SIGNATURE"
     adresses = destinataires.Value
     
    'Assignation de l'application Outlook :
    Set OutlookApp = CreateObject("outlook.application")
    
    'Assignation des objets Outlook :
    Set OutlookMail = OutlookApp.CreateItem(olMailItem)
    
    'remplissage sujet et objet
    OutlookMail.Subject = sujet
    OutlookMail.Body = message
    
    'remplissage destinaires
    For i_soc = 1 To UBound(adresses, 2)
        For i_dest = 1 To UBound(adresses, 1)
           Set dest_A = OutlookMail.Recipients.Add(adresses( i_dest, i_soc))
           dest_A.Type = olTo
        Next i_dest
    Next i_soc
     
    'envoie le message
    OutlookMail.Send
 
 End If


End Sub



 
0
MIMOHUGUES Messages postés 4 Date d'inscription   Statut Membre Dernière intervention  
 
merci pour votre aide vraiment :) par contre j'ai entrée les modification mais j'ai toujours un message d'erreur qui me dit "l'indice n'appartient pas a la sélection" j'ai essayé des modification ce week end mais rein de concluant
0
thev Messages postés 1986 Date d'inscription   Statut Membre Dernière intervention   713 > MIMOHUGUES Messages postés 4 Date d'inscription   Statut Membre Dernière intervention  
 
Pour que je puisse vous aider, il faut me préciser à quelle instruction se produit l'erreur.
Il se peut que la modification de la fin du code ci-dessous (après l'instruction message =) vous permette d'y voir plus clair.
Pour que ça fonctionne, il faut qu'au moins une des variables booléennes : IBM, ENGIE, GRT, TELMMA, PCS, MULTITECH soit égale à TRUE. En bonne logique, votre procédure devrait être la suivante : 

     
Public Sub EnvoiAutomatiqueMail(IBM, ENGIE, GRT, TELMMA, PCS, MULTITECH)  
 
 If MsgBox("Souhaitez-vous envoyer ce mail ?", vbQuestion + vbYesNo, "ENVOIE MAIL") = vbYes Then

     Dim OutlookApp As Object
     Dim OutlookMail As Object
     Dim adresse As String
     Dim adresses()
     Dim message As String
     Dim sujet As String
     Dim destinataires As Range
         
     If IBM Then
        If destinataires Is Nothing Then
            Set destinataires = Range("D63,D64,D65,D66")
        Else
            Set destinataires = Union(destinataires, Range("D63,D64,D65,D66"))
        End If
     End If
     If ENGIE Then
        If destinataires Is Nothing Then
            Set destinataires = Range("E63,E64,E65,E66")
        Else
            Set destinataires = Union(destinataires, Range("E63,E64,E65,E66"))
        End If
     End If
     If GRT Then
        If destinataires Is Nothing Then
            Set destinataires = Range("F63,F64,F65,F66")
        Else
            Set destinataires = Union(destinataires, Range("F63,F64,F65,F66"))
        End If
     End If
     If TELMMA Then
        If destinataires Is Nothing Then
            Set destinataires = Range("A63,A64,A65,A66")
        Else
            Set destinataires = Union(destinataires, Range("A63,A64,A65,A66"))
        End If
     End If
     If PCS Then
        If destinataires Is Nothing Then
            Set destinataires = Range("B63,B64,B65,B66")
        Else
            Set destinataires = Union(destinataires, Range("B63,B64,B65,B66"))
        End If
     End If
     If MULTITECH Then
         If destinataires Is Nothing Then
            Set destinataires = Range("C63,C64,C65,C66")
        Else
            Set destinataires = Union(destinataires, Range("C63,C64,C65,C66"))
        End If
     End If
     
     sujet = " Intervention EUROPE AVENUE "
     message = "Bonjour" & " " & Range("CT44") & vbCrLf & vbCrLf & "Bienvenue sur les tests" & vbCrLf & vbCrLf & "SIGNATURE"
     If destinataires Is Nothing Then
       MsgBox "Aucun destinataire sélectionné - Pas d'envoi"
       Exit Sub
     End If
     If destinataires.Count > 1 Then
        adresses = destinataires.Value
     Else
        adresse = destinataires.Value
     End If

     
    'Assignation de l'application Outlook :
    Set OutlookApp = CreateObject("outlook.application")
    
    'Assignation des objets Outlook :
    Set OutlookMail = OutlookApp.CreateItem(olMailItem)
    
    'remplissage sujet et objet
    OutlookMail.Subject = sujet
    OutlookMail.Body = message
    
    'remplissage destinaires
    If destinataires.Count > 1 Then
        For i_soc = 1 To UBound(adresses, 2)
            For i_dest = 1 To UBound(adresses, 1)
               Set dest_A = OutlookMail.Recipients.Add(adresses(i_dest, i_soc))
               dest_A.Type = olTo
            Next i_dest
        Next i_soc
    Else
        OutlookMail.To = adresse
    End If
     
    'envoie le message
    OutlookMail.Send
 
 End If


End Sub
0
MIMOHUGUES Messages postés 4 Date d'inscription   Statut Membre Dernière intervention   > thev Messages postés 1986 Date d'inscription   Statut Membre Dernière intervention  
 
parfait ca marche !! :) merci bcp Thev vraiment !
0

Discussions similaires

Bouton case à cocher grisé
Kris-Of-Reunion -
Le Pingou -

3 réponses
créer une case a cocher sur open office
Mel0612 -
soso -

5 réponses
Case à cocher dans Outlook
JayJeff -
thev -

1 réponse
URGENT - codes ALT + ???
infotruc -
infotruc -

2 réponses
Supprimer cases à cocher
Claude 1950 -
Sherlock Hoimes -

13 réponses