Envoyer mail à plusieurs destinataires avec case à cocher

Fermé
VALENTIN - 12 mai 2016 à 17:38
MIMOHUGUES Messages postés 4 Date d'inscription jeudi 12 mai 2016 Statut Membre Dernière intervention 19 mai 2016 - 19 mai 2016 à 12:24
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

thev Messages postés 1882 Date d'inscription lundi 7 avril 2008 Statut Membre Dernière intervention 26 octobre 2024 689
Modifié par thev le 13/05/2016 à 12:08
        
'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 jeudi 12 mai 2016 Statut Membre Dernière intervention 19 mai 2016
13 mai 2016 à 12:24
merci de ton intervention, mais ca ne marche pas ...
0
thev Messages postés 1882 Date d'inscription lundi 7 avril 2008 Statut Membre Dernière intervention 26 octobre 2024 689 > MIMOHUGUES Messages postés 4 Date d'inscription jeudi 12 mai 2016 Statut Membre Dernière intervention 19 mai 2016
Modifié par thev le 13/05/2016 à 12:29
Je vois une erreur

' Assignation des objets Outlook :
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
0
MIMOHUGUES Messages postés 4 Date d'inscription jeudi 12 mai 2016 Statut Membre Dernière intervention 19 mai 2016
13 mai 2016 à 12:33
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
thev Messages postés 1882 Date d'inscription lundi 7 avril 2008 Statut Membre Dernière intervention 26 octobre 2024 689
Modifié par thev le 13/05/2016 à 15:02
 

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 jeudi 12 mai 2016 Statut Membre Dernière intervention 19 mai 2016
17 mai 2016 à 13:58
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 1882 Date d'inscription lundi 7 avril 2008 Statut Membre Dernière intervention 26 octobre 2024 689 > MIMOHUGUES Messages postés 4 Date d'inscription jeudi 12 mai 2016 Statut Membre Dernière intervention 19 mai 2016
Modifié par thev le 17/05/2016 à 17:07
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 jeudi 12 mai 2016 Statut Membre Dernière intervention 19 mai 2016 > thev Messages postés 1882 Date d'inscription lundi 7 avril 2008 Statut Membre Dernière intervention 26 octobre 2024
19 mai 2016 à 12:24
parfait ca marche !! :) merci bcp Thev vraiment !
0