Adding CC to mail ignoring body part of the mail

[Nashid]

Here is the macro code that I am trying to use, when I try to add cc it sends mails without body part. any body have any idea why this happening. please help me to correct all of this

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 Email As String, Subj As String
Dim Msg As String, CC As String, URL As String
Dim r As Integer, x As Double

For r = 2 To 2 'data in rows 2-17
' Get the email address
Email = Cells(r, 3) & vbCrLf
CC = Cells(r, 4)
' Message subject


Subj = "REMINDER"


' Compose the message
Msg = ""
Msg = Msg & "Dear " & Cells(r, 2) & "," & vbCrLf & vbCrLf


Msg = Msg & "This is to remind you, cash advance are due."
Msg = Msg & "Please do not respond to this mail."

' Replace spaces
Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")

' Replace carriage returns
Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")


' Create the URL
URL = "mailto:" & Email & "&cc=" & CC & "?subject=" & Subj & "&body=" & Msg


' Execute the URL (start the email client)
ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus


' Wait one seconds before sending keystrokes
Application.Wait (Now + TimeValue("0:00:02"))
Application.SendKeys "%s"
Next r
End Sub