Macro to send email automatically.

  • Thread starter Thread starter Dan Wood
  • Start date Start date
D

Dan Wood

I have a macro set up to send an email to users when there password is due to
expire.

How do i get the email to actually send. The mail is populated and ready to
send but wont actually go. Is there a line i need to add at the end of the
macro to send the mail?
 
The mail programe is Outlook, and the code is as follows:-

Sub SendEmail()
Dim Email As String, Subj As String
Dim Msg As String, URL As String
Email = Range("H1")
For Each c In Range("D7:D30")
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 0&, vbNullString, URL, vbNullString, vbNullString,
vbNormalFocus

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

End If
Next
End Sub
 
Uncomment this two lines (remove the ' before it)

'Application.Wait (Now + TimeValue("0:00:02"))
'Application.SendKeys "%s"

If you use Outlook there are other examples that use the Outlook object modelalso on my site
Sendkeys is not a very good option to use
http://www.rondebruin.nl/sendmail.htm
 
Back
Top