Autres Envoi de mails avec liste de destinataires

[fifounet]

Bonjour, j'utilise une macro pour envoyer un mail à 300 destinataires différents.
Elle fonctionne très bien avec Excel et Office 2019, par contre avec Office 2003 installé sur le PC de notre association, les majuscules passent en minuscules!
Je ne trouve pas la solution. Quelqu'un a-t-il une idée?
voici le code:

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

Merci

 

[fifounet]

Bonsoir, solution trouvée, autre macro trouvée sur le web et qui fonctionne!