Envoyer des mails à plusieurs destinataires selectionner

Question

Bonjour,

Je cherche le moyen d'envoyer depuis mon formulaire Excel un mail aux destinataires sélectionner dans la listbox (Listbox1).

Dans le formulaire je sélectionne plusieurs destinataires mais je ne sais pas comment faire pour que cela fonctionne.

Private Sub BP_ENVOI_Click()
LI = 0 'réinitialise la variable LI (déclarée publique dans le module [Module1])

Dim objOL
  Dim objAppt
  Dim lgDerLig As Long
  Dim Ligne As Long
  Const olAppointmentItem = 1
  Const olMeeting = 1
  
  '''lgDerLig = Range("A65536").End(xlUp).Row
  
    myCheck = MsgBox("Ajout d'une pièce jointe aux invitations ?", vbYesNo)
    If myCheck = vbYes Then
'        Do this
       Dim sFichier As Variant
       sFichier = Application.GetOpenFilename(, , "Sélectionner le fichier à joindre.")

' .Attachments.Add sFichier

Else
' do that
MsgBox ("Pas de pièce jointe ajoutée.")
    End If

'''''For Ligne = 3 To lgDerLig
  Set objOL = CreateObject("Outlook.Application")

' entree agenda
  
  Set objAppt = objOL.CreateItem(olMeeting)
  With objAppt
    .Subject = Me.Lbl_PROJET.Caption
    .Start = Me.Lbl_DATE_ECHEANCE.Caption & " " & Me.Txt_HEURE_DEBUT.Value
    .End = Me.Lbl_DATE_ECHEANCE.Caption & " " & Me.Txt_HEURE_FIN.Value
    .Location = "Bureau"
    .Body = Me.Lbl_PROJET.Caption & " " & Me.Lbl_NUMERO.Caption & " " & Me.Lbl_LOT.Caption & " " & Me.Lbl_FOURNISSEUR.Caption & " " & Me.Lbl_OFFRE.Caption           'Message principal
    .BusyStatus = olBusy
    .Categories = ""
    .ReminderSet = True
    .ReminderMinutesBeforeStart = Worksheets("CONFIG").Range("B6")

.ReminderOverrideDefault = True
    .ReminderPlaySound = True
    .Importance = olImportanceHigh
    
    If sFichier <> False _
    Then .Attachments.Add sFichier
   
    .MeetingStatus = olMeeting
    
'participant facultatif
    
    '''.OptionalAttendees = ""
    
'participant obligatoire
       
    .RequiredAttendees = "***@***"   ''Cells(Ligne, 2)
    .Send
  End With

Set objAppt = Nothing
  Set objOL = Nothing

'Next Ligne
     
MsgBox "Les invitations ont été envoyées !"

End Sub

Merci d'avance pour votre aide.

Bonne journée à tous

cs_Le Pivert · Answer

Bonjour,

Un exemple ici

Et là

pour adapter ce code à la ListBox:

Private Sub CommandButton1_Click()
 Dim i As Byte
 Dim dest As String
 'boucle sur les éléments de la listbox
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
        dest = ListBox1.List(i)
        Range("B1") = Range("B1") & dest & ";"
        End If
      Next i
      Range("B1") = Left(Range("B1"), Len(Range("B1")) - 1) 'supprime dernier caractere
End Sub

ensuite à mettre dans le code de l'envoi:

.To = Range("B1")

voilà

netparty · Answer

Bonjour @cs_Le Pivert

Merci pour ton aide

Bonne journée

Envoyer des mails à plusieurs destinataires selectionner

2 réponses

Votre réponse

Discussions similaires