' Declare all variables.
Option Explicit
On Error Resume Next
Dim objSendMail
Dim strTo, strFrom,fs,f
Dim strSubject, strBody,I
Dim ObjCon,SqlQuery,RecObj,intCount,cmdObj,strPowered,strunScribe
Dim iShowCount,iShowLink,strFooter,bolCC,dtSendTime,intEmailedId
Dim iemailFrom
dtSendTime=Now()
intCount=0
Const strConn="Provider=SQLOLEDB;Data Source=sql2014;Initial Catalog=SheddPark;User Id=sa;password=letmein@cliff64;"
Const Appending=8
Const adCmdStoredProc = &H0004
Const adParamInput = &H0001
Const adTinyInt = 16
Const adInteger = 3
Const adVarChar = 200
Const adChar = 129
Const adDate=7

'***CREATE CONNECTION OBJECT
Set ObjCon=CreateObject("adodb.connection")
With ObjCon
.ConnectionString=strConn
.Open 
End With

'***CREATE COMMAND OBJECT
Set cmdObj =CreateObject("ADODB.Command")
With cmdObj
 .ActiveConnection = ObjCon
 .CommandText = "DBO.USP_BlastEmailing" 
 .CommandType = adCmdStoredProc
 .Parameters.Append .CreateParameter("@activitytype",adTinyInt,adParamInput,,0)
 .Parameters.Append .CreateParameter("@dtSendOn",adDate,adParamInput,,dtSendTime)
 .Parameters.Append .CreateParameter("@intAdultId",adInteger,adParamInput)
 .Parameters.Append .CreateParameter("@vchremail",adVarChar,adParamInput,300)
 .Parameters.Append .CreateParameter("@intMailId",adInteger,adParamInput)
 Set RecObj=CreateObject("adodb.recordset")
 Set RecObj=.Execute()
With RecObj
If .EOF=False Then
bolCC=.Fields(10)
Do While .EOF=False
If isValidEmail(.Fields(1)) = True Then
intCount=intCount+1
strSubject = .Fields(2) : strBody=.Fields(3) : strFrom=.Fields(7) : strTo=.Fields(1) : strFooter=.Fields(9)
intEmailedId =.Fields(11)
'strSubject=strSubject&" ("&intEmailedId&"-"&.Fields(0)&")"
If .Fields(13) = 1 Then
strPowered="<br/><label style=""font-size:small;font-weight:bold;font-style:italic;font-family:verdana"">"&_
         "Powered by SportsManager Solutions<br/>www.SportsManager.us</label></center>"
strunScribe="<br/><a target=""_blank"" href=""http://www.sportsmanager.us/Unsubscribe.asp?Org_id="&.Fields(8)
strunScribe=strunScribe&"&FamilyId="&.Fields(0)&"&FamilyEmail="&strTo&""">"
strunScribe=strunScribe&"<font color=""red"" size=""4"">Unsubscribe Option: Click here if you no longer want "&_
						"to receive email from this organization</font></a><hr size=""1""/>"
strunScribe=strunScribe&strFooter&" <br/>To:"&strTo
Else
strPowered="" : strunScribe = ""
End If
strBody=strBody&strunScribe&strPowered
' The following section creates the mail object and sends the mail.
Set objSendMail = CreateObject("CDO.Message")
	objSendMail.From     = "notices@sportsmanager.us"
	objSendMail.To       = strTo
	If strFrom <> "" Then
		objSendMail.ReplyTo  = strFrom
	End If 
	If bolCC="T" Then objSendMail.BCc="copy@sportsmanager.us"	
	objSendMail.Subject  = strSubject
	objSendMail.HTMLBody = strBody
    objSendMail.Send
Set objSendMail = Nothing
End If
cmdObj.Parameters("@intAdultId").Value=.Fields(0)
cmdObj.Parameters("@vchremail").Value=.Fields(1)
cmdObj.Parameters("@intMailId").Value=.Fields(12)
cmdObj.Parameters("@activitytype").Value=2
cmdObj.Execute()
.MoveNext
Loop
End If
.Close()
End With
.Parameters("@activitytype").Value=1
.Execute()
.Parameters.Delete("@activitytype")
.Parameters.Delete("@dtSendOn")
End With
'***************************CLEAR ALL OBJECT***************************************
   Set cmdObj=Nothing : Set RecObj=Nothing : ObjCon.Close() : Set ObjCon=Nothing
'**********************************************************************************
Set fs=CreateObject("Scripting.FileSystemObject")
Set f=fs.OpenTextFile("C:\ScheduleTask\emailLogs.txt", Appending) 
f.Write VBCRLF&intCount&" Emails Sent Sucessfully At "&Now&VBCRLF&"------------------"
f.close()
Set fs=Nothing


Function isValidEmail(myEmail)
  Dim isValidE
  'dim regEx
  isValidE = True
  'set regEx = New RegExp
  'regEx.IgnoreCase = False
  'regEx.Pattern = "^[a-zA-Z0-9][\w\.-]*[a-zA-Z0-9]@[a-zA-Z0-9][\w\.-]*[a-zA-Z0-9]\.[a-zA-Z][a-zA-Z\.]*[a-zA-Z]$"
  'isValidE = regEx.Test(myEmail)
  If LCase(Left(myEmail,15)) ="unsubscribed on" Or Trim(myEmail)=""  Then
       isValidE=False
   Else
	   isValidE=True
   End If 
   isValidEmail = isValidE
End Function