PDA

View Full Version : Solved: Need VBS quick help with If loop :(



BVks1
03-05-2012, 04:03 PM
Hello! I have already created my database that will generate an email in outlook for my team when their cards are expired - I was able to get the VBA code to say everything I needed in the email with the correct format, but am having a little trouble with VBA recognizing an IF statment that will ONLY send out an email when the cards expire. Currently it sends out emails to the entire datase. I have been playing with code to try to get it to recognize when

If Cells(r, 9) = "EXPIRED" Then,
My SendEmail code
Else If
Exit Sub
End IF
End Sub

Not Working!!

Please Help....Hope I dont have to completely rewrite my entire code for this lttle bit!

Below is my code....

Sub SendEMail()

Dim Email As String, Subj As String
Dim Msg As String, URL As String
Dim r As Integer, x As Double
For r = 2 To 4 'data in rows 2-4
If Cells(r, 9) = "CURRENT" Then
Exit Sub
End If
' Get the email address
Email = Cells(r, 4)
' Message subject
Subj = "Renewal Card"
' Compose the message
Msg = ""
Msg = Msg & "Dear " & Cells(r, 1) & "," & vbCrLf & vbCrLf
Msg = Msg & "This is a reminder that you are approaching the expiration date for the card: "
Msg = Msg & Cells(r, 5).Text & ", specifically relating to the "
Msg = Msg & Cells(r, 8).Text & ". Please contact your site safety department to schedule training and renewal before your expiration date of "
Msg = Msg & Cells(r, 7).Text & "." & vbCrLf & vbCrLf
Msg = Msg & "********" & vbCrLf
Msg = Msg & "******!" & vbCrLf
' 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:0:02"))
Application.SendKeys "%s"
Next r
End Sub