bonjour à tous,

Après plusieurs recherches infructueuses, je me lance à vous demander de l'aide.
J'ai un fichier Excel a partir duquel je peux envoyer un mail à plusieurs destinataires lors de son enregistrement.
Cette macro fonctionne correctement à partir de 2 destinataires et plus. Seulement lorsque je souhaite l'envoyer à un destinataire unique ça ne fonctionne pas et un mail est généré pour tous les destinataires du fichier.

Je souhaiterais pouvoir envoyer un mail à un seul ou plusieurs destinataires en ayant la possibilité de sélectionner les adresses sur la feuille Excel comme c'est déjà le cas dans ma macro actuelle avec l'outil "KuTool for Excel".

Je met ci-dessous mon code actuel qui fonctionne pour plusieurs destinataires.

J'espère être assez précise dans ma demande.

Merci à tous pour votre aide.

Marion

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 
  If MsgBox("Voulez-vous envoyer un mail de mise à jour?", vbYesNo, "Mail d'information") = vbYes Then
 
  Sheets("validations").Select
 
 
    Dim xRg As Range
    Dim xRgEach As Range
    Dim xRgVal As String
    Dim xAddress As String
    Dim xOutApp As Object
    Dim oItem As Object
    Const olMailItem As Long = 0
 
    On Error Resume Next
    xAddress = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Selectionner les adresses a envoyer", "KuTools For Excel", xAddress, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Set xOutApp = CreateObject("Outlook.Application")
    Set xRg = xRg.SpecialCells(xlCellTypeConstants, xlTextValues)
    Set oItem = xOutApp.createItem(olMailItem)
    For Each xRgEach In xRg
        xRgVal = xRgEach.Value
        If xRgVal Like "?*@?*.?*" Then
            Set xMailOut = xOutApp.createItem(olMailItem)
            With xMailOut
                .To = xRgVal
                .Subject = "Mise à jour du fichier projet " & Range("B1") & ""
                .Body = "Le fichier projet " & Range("B1") & " a été complété" _
 
                .Display
                '.Send
            End With
        End If
    Next
    Set xMailOut = Nothing
    Set xOutApp = Nothing
    Application.ScreenUpdating = True
 
    End If
 
 End Sub