VB Help Needed

[Dan Wood]

Can someone help me with the following code:-

Sub SendEmail()
Dim Email As String, Subj As String
Dim Msg As String, URL As String
Email = Range("A5")
For Each c In Range("D730")
If c.Value = 0 Then
SySname = c.Offset(, -3).Value
Subj = SySname


Msg = ""
Msg = Msg & "Hi" & Cells(ActiveCell.Row, 6) & "," & vbCrLf & vbCrLf &
"Your AS400 password is due to expire on the above mentioned system. Please
log on and change your password" & vbCrLf & vbCrLf & "Once you have done this
please update the spreadsheet to reflect the new password, and the date it
was changed."


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


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


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


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


'Wait two seconds before sending keystrokes
'Application.Wait (Now + TimeValue("0:00:02"))
'Application.SendKeys "%s"


End If
Next

It used to work but for some reason now it is flagging up the ShellExecute
field as an error. The macro is meant to send an automatic email but for some
reason wont even open the email.

Also can someone confirm that this script will pick up the email address
from field A5.

Thanks in advance