Why did this code stop working ?

[Corey]

Sub Outlook_Express()
ActiveSheet.Select
With ActiveWorksheet
Range("B6").Select
ActiveCell.Value = ActiveWorkbook.Worksheets.Count - 1
Range("A1:I46").Select
Dim msg As String, cell As Range
Dim Recipient As String, Subj As String, HLink As String
Dim Recipientcc As String, Recipientbcc As String
Recipient = "(e-mail address removed)"
Recipientcc = ActiveSheet.Range("E39")
Recipientbcc = "(e-mail address removed)"
Subj = ActiveSheet.Range("A47")
msg = "Dear customer" & vbNewLine & vbNewLine
For Each cell In ActiveSheet.Range("A1:I46")
msg = msg & vbNewLine & cell
Next cell
msg = WorksheetFunction.Substitute(msg, vbNewLine, "%0D%0A")
msg = WorksheetFunction.Substitute(msg, vbLf, "%0D%0A")
HLink = "mailto:" & Recipient & "?" & "cc=" & Recipientcc & "&" & "bcc=" & Recipientbcc & "&"
HLink = HLink & "subject=" & Subj & "&"
HLink = HLink & "body=" & msg
Application.SendKeys "%s"
End With

End Sub

Suddenly stopped sending the selected range ???