'On Error Resume Next
Const PAGE_SIZE=25
Const adCmdText = &H0001
Const adCmdTableDirect = &H0200
Const adCmdFile = &H0100
Const adOpenForwardOnly = 0
Const adOpenKeyset = 1
Const adLockReadOnly = 1
Const adLockOptimistic = 3
Const adExecuteNoRecords = &H00000080
Const adUseClient = 3
Const adStateClosed=0
Const adStateOpen=1
Const adCmdStoredProc = &H0004
Const adParamInput = &H0001
Const adParamOutput = &H0002
Const adVarChar = 200
Const adInteger = 3
Const adTinyInt =16
Const adDate=7
Const adBoolean=11
Const adChar=129
Const adDecimal =14
Const adNumeric = 131
Const adLongVarChar = 201
'***EMAIL CONSTANT
Const cdoContentDisposition = "urn:schemas:mailheader:content-disposition"
Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"
Const cdoSendUsingPort = 2
Const cdoSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
Const cdoSMTPServerPort = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"
Const cdoSMTPConnectionTimeout = "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"
Const cdoSMTPAuthenticate = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"
Const cdoBasic = 1
Const cdoSendUserName = "http://schemas.microsoft.com/cdo/configuration/sendusername"
Const cdoSendPassword = "http://schemas.microsoft.com/cdo/configuration/sendpassword"
Dim strBCC : strBCC = ""
Const strConn = "Provider=SQLOLEDB;Data Source=190.92.172.185;Initial Catalog=cloudspo_sportsmgr;User Id=admin_su;password=letmein@cliff64"
'Const strFrom = "notices@sportsmanager.us"
'Const EMAIL_SERVER = "smtp-relay.brevo.com"
'Const EMAIL_PORT = 587
'Const EMAIL_USER_NAME = "7984cf001@smtp-brevo.com"
'Const EMAIL_PASSWORD = "ynXMKsExNz2HpB5r"
'Const EMAIL_TIMEOUT = 10
'Const EMAIL_SERVER = "mail.sportsmanager.us"
'Const EMAIL_PORT = 25
'Const EMAIL_USER_NAME = "notices@sportsmanager.us"
'Const EMAIL_PASSWORD = "Gy5au71bnO2k"
'Const EMAIL_TIMEOUT = 10
Const strFrom = "notices@sportsmanager.us"
Const EMAIL_FORM = "notices@sportsmanager.us"
Const EMAIL_SERVER = "send.smtp.com"
Const EMAIL_PORT = 25
Const EMAIL_USER_NAME = "hartys@comcast.net"
Const EMAIL_PASSWORD = "Shadow1958!"
Const EMAIL_TIMEOUT = 10
'Const strFrom = "donotreply@sportsmanager.us"
'Const EMAIL_FORM = "donotreply@sportsmanager.us"
'Const EMAIL_SERVER = "190.92.171.33"
'Const EMAIL_PORT = 25
'Const EMAIL_USER_NAME = "donotreply@sportsmanager.us"
'Const EMAIL_PASSWORD = "Shadow@1958"
'Const EMAIL_TIMEOUT = 10
Dim strSQL,RecObj,objConn
Dim sContent,sPowered,strTo
Set objConn=CreateObject("adodb.connection")
With objConn
.ConnectionString=strConn
.Open
End With
strSQL = "EXECUTE dbo.USP_BlastEmailing 0"
sPowered = "
Powered by SportsManager Solutions
www.SportsManager.us
"
Set RecObj = CreateObject("adodb.recordset")
With RecObj
.Open strSQL,objConn
If .EOF = False Then
intMailId = .Fields("MailId")
bolCC=.Fields(10)
If bolCC <> "T" Then
strBCC = ""
End If
Do While .EOF = False
strSubject = .Fields("MailSubject")
strBody = .Fields("MailBody")
strTo = .Fields("Email")
strReply = .Fields("EmailFrom")
sFooter = .Fields("MailFooter")
strReadImg = "![]()
"
sunScribe = "
"
sunScribe = sunScribe & sFooter &" To:"&strTo
sContent = strBody & sunScribe & sPowered & strReadImg
If strTo <> "" And strSubject <> "" And sContent <> "" Then
If isValidEmail(strTo) Then
Call Send_Email_With_Reply(strTo,strSubject,sContent,strCC,strReply)
End If
End If
Call DeleteEmail(.Fields("AdultID"),strTo,.Fields("MailId"))
.MoveNext
Loop
Call TruncateEmail(intMailId)
End If
.Close()
End With
Set RecObj = Nothing
'WScript.Echo "Mail Sent Successfully"
Sub TruncateEmail(MailId)
Dim cmdObj
Set cmdObj =CreateObject("adodb.command")
With cmdObj
.ActiveConnection = objConn
.CommandText = "DBO.USP_BlastEmailing"
.CommandType = adCmdStoredProc
.Parameters.Append .CreateParameter("@activitytype",adInteger,adParamInput,,1)
.Parameters.Append .CreateParameter("@dtSend",adDate,adParamInput,,Now())
.Parameters.Append .CreateParameter("@intAdultId",adInteger,adParamInput,,0)
.Parameters.Append .CreateParameter("@vchrEmail",adVarChar,adParamInput,300,"")
.Parameters.Append .CreateParameter("@intMailId",adInteger,adParamInput,,MailId)
.Execute()
.Parameters.Delete("@activitytype")
.Parameters.Delete("@dtSend")
.Parameters.Delete("@intAdultId")
.Parameters.Delete("@vchrEmail")
.Parameters.Delete("@intMailId")
End With
Set cmdObj = Nothing
End Sub
Sub DeleteEmail(AdultID,Email,MailId)
Dim cmdObj
Set cmdObj =CreateObject("adodb.command")
With cmdObj
.ActiveConnection = objConn
.CommandText = "DBO.USP_BlastEmailing"
.CommandType = adCmdStoredProc
.Parameters.Append .CreateParameter("@activitytype",adInteger,adParamInput,,2)
.Parameters.Append .CreateParameter("@dtSend",adDate,adParamInput,,Now())
.Parameters.Append .CreateParameter("@intAdultId",adInteger,adParamInput,,AdultID)
.Parameters.Append .CreateParameter("@vchrEmail",adVarChar,adParamInput,300,Email)
.Parameters.Append .CreateParameter("@intMailId",adInteger,adParamInput,,MailId)
.Execute()
.Parameters.Delete("@activitytype")
.Parameters.Delete("@dtSend")
.Parameters.Delete("@intAdultId")
.Parameters.Delete("@vchrEmail")
.Parameters.Delete("@intMailId")
End With
Set cmdObj = Nothing
End Sub
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]@[\w\.-]*[a-zA-Z0-9]\.[a-zA-Z][a-zA-Z\.]*[a-zA-Z]$"
'isValidE = regEx.Test(myEmail)
isValidEmail=isValidE
End Function
Sub Send_Email_With_Reply(strTo,strSubject,strBody,strCC,strReply)
Dim Mail,strHost
If strSubject = "" Then
Exit Sub
End If
If strBody = "" Then
Exit Sub
End If
If strTo = "" Then
Exit Sub
End If
If IsNull(strTo) = True Then
Exit Sub
End If
Set objConfig = CreateObject("CDO.Configuration")
Set Fields = objConfig.Fields
With Fields
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = EMAIL_SERVER
.Item(cdoSMTPServerPort) = EMAIL_PORT
.Item(cdoSMTPAuthenticate) = cdoBasic
.Item(cdoSendUserName) = EMAIL_USER_NAME
.Item(cdoSendPassword) = EMAIL_PASSWORD
.Item(cdoSMTPConnectionTimeout) = EMAIL_TIMEOUT
.Update
End With
Set mailObj=CreateObject("CDO.Message")
Set mailObj.Configuration = objConfig
With mailObj
.Subject=strSubject
.From = strFrom
.To=strTo
If strCC <> "" Then
.CC = strCC
End If
If strBCC <> "" Then
.BCc = strBCC
End If
.ReplyTo = strReply
.HTMLBody = strBody
.HTMLBodyPart.ContentTransferEncoding = "quoted-printable"
.Send
End With
Set mailObj=Nothing
Set objConfig = Nothing
End Sub