Envoyer mail à plusieurs destinataires avec case à cocher

VALENTIN -  
MIMOHUGUES Messages postés 4 Statut Membre -
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

  1.
    thev Messages postés 2005 Date d'inscription   Statut Membre Dernière intervention   721
     
            
        '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
    1. MIMOHUGUES Messages postés 4 Statut Membre
       
      merci de ton intervention, mais ca ne marche pas ...
      0
      1. thev Messages postés 2005 Date d'inscription   Statut Membre Dernière intervention   721 > MIMOHUGUES Messages postés 4 Statut Membre
         
        Je vois une erreur 

         ' Assignation des objets Outlook :
            Set OutlookMail =  OutlookApp.CreateItem(olMailItem)
        0
    2. MIMOHUGUES Messages postés 4 Statut Membre
       
      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
  2. thev Messages postés 2005 Date d'inscription   Statut Membre Dernière intervention   721
     
     

    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
    1. MIMOHUGUES Messages postés 4 Statut Membre
       
      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
      1. thev Messages postés 2005 Date d'inscription   Statut Membre Dernière intervention   721 > MIMOHUGUES Messages postés 4 Statut Membre
         
        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
      2. MIMOHUGUES Messages postés 4 Statut Membre > thev Messages postés 2005 Date d'inscription   Statut Membre Dernière intervention  
         
        parfait ca marche !! :) merci bcp Thev vraiment !
        0

Discussions similaires

cocher des cases
beli -
karine -

6 réponses
URGENT - codes ALT + ???
infotruc -
infotruc -

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

3 réponses
Comment cocher une case deja créer ?
olliane -
HelpiOS -

3 réponses
cocher une case avec le clavier
Pikoulon -
Fitz -

10 réponses