Autres Envoi de mails avec liste de destinataires

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
                         ByVal hwnd As Long, ByVal lpOperation As String, _
                         ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, _
                         ByVal nShowCmd As Long) As Long
Sub SendEMail()
    Dim xEmail As String
    Dim xSubj As String
    Dim xMsg As String
    Dim xURL As String
    Dim i As Integer
    Dim k As Double
    Dim xCell As Range
    Dim xRg As Range
    Dim xTxt As String
    
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Sélectionner les cellules:", " ", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    If xRg.Columns.Count <> 4 Then
        MsgBox " Sélectionner 4 colonnes !", , " "
        Exit Sub
    End If
    For i = 1 To xRg.Rows.Count
'       Addresse mail
        xEmail = xRg.Cells(i, 3)
'       Message sujet
        xSubj = "Votre N° de carte de connexion"
'       Compose le message
        xMsg = ""
        xMsg = xMsg & "Bonjour " & xRg.Cells(i, 1) & " " & xRg.Cells(i, 2) & "," & vbCrLf
        xMsg = xMsg & "Voici votre numéro de carte pour vous connecter" & vbCrLf
        xMsg = xMsg & xRg.Cells(i, 4).Text & vbCrLf
        ' Replace spaces with %20 (hex)
        xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
        xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
'       Replace carriage returns with %0D%0A (hex)
        xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
'       Create the URL
        xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
'       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "{NUMLOCK}%s", True
 Next
End Sub