'--------------------------------------------------------------------
'
' Mailout using CDONTS.NewMail
'
'--------------------------------------------------------------------
' declare all variables
Option Explicit
Dim strFrom, strBody, strSubject
Dim EmailSuccess, EmailCC, EmailFailure, EmailDebug
Dim oCon
Dim WshNetwork
Dim strServerName
Dim blnCon
Dim blnSendMail
Dim ThisDate
Dim DayOfWeek
Dim DayOfMonth
Dim WeekStartDate
Dim WeekEndDate
Dim MonthStartDate
Dim MonthEndDate
Dim blnDebugOn
blnDebugOn = false ' if blnDebugOn is true, email will be sent to developer with more detailed error description
' mail constants (some are for reference)
Const CdoBodyFormatHTML = 0 ' Body property is HTML
Const CdoBodyFormatText = 1 ' Body property is plain text (default)
Const CdoMailFormatMime = 0 ' NewMail object is in MIME format
Const CdoMailFormatText = 1 ' NewMail object is plain text (default)
Const CdoLow = 0 ' Low importance
Const CdoNormal = 1 ' Normal importance (default)
Const CdoHigh = 2 ' High importance
'ADO constants
Const adCmdText = &H0001
Const adCmdTable = &H0002
Const adCmdStoredProc = &H0004
Const adInteger = 3
Const adParamInput = &H0001
'Server constants
Const DevServer = "DevServerName"
Const TestServer = "TestServerName"
Const ProdServer = "ProdServerName"
'ConnectionString
Const strDBConnection = "dsn=<<DSN_name>>;uid=<<username>>;pwd=<<password>>"
' email subject and sender
strFrom = "yourname@domain.com"
' determine environment and set email recipients as appropriate
Set WshNetwork = WScript.CreateObject("WScript.Network")
strServerName = Trim(CStr(WshNetwork.ComputerName))
Select Case UCase(strServerName)
Case DevServer
strSubject = "Time Entry Reminder - Dev "
EmailSuccess = "developer@company.com"
EmailFailure = "developer@company.com"
Case TestServer
strSubject = "Time Entry Reminder - Test "
EmailSuccess = "developer@company.com"
EmailFailure = "developer@company.com"
Case ProdServer
strSubject = "Time Entry Reminder"
EmailSuccess = "appadmin@company.com"
EmailCC = "developer@company.com"
EmailFailure = "appadmin@company.com"
End Select
If blnDebugOn Then
EmailSuccess = "developer@company.com"
EmailFailure = "developer@company.com"
EmailDebug = "developer@company.com"
End If
'Determine if it is the end of the work week or end of month
ThisDate = Date()
DayOfWeek = WeekDay(ThisDate)
DayOfMonth = Day(ThisDate)
WeekStartDate = DateAdd("y", -(DayOfWeek), ThisDate)
WeekEndDate = DateAdd("y", 6, CDate(WeekStartDate))
MonthStartDate = CDate(Year(ThisDate) &"/"& Month(ThisDate) &"/01")
MonthEndDate = DateAdd("y", -DayOfMonth, DateAdd("m", 1, ThisDate))
' if today is the end of the work week or end of month then send the emails
If ThisDate = WeekEndDate Or (ThisDate = MonthEndDate And (WeekDay(ThisDate) >= 2 And WeekDay(ThisDate) <= 6)) Then
blnSendMail = true
Else
blnSendMail = false
End If
blnCon=OpenConnection()
If blnCon And blnSendMail Then
Call MailoutReminders()
Call CloseConnection()
ElseIf blnCon And Not blnSendMail Then
'End Script
Else
' failure notification
strBody = "<font face=Tahoma color=red size=3pt>Unable to send time entry reminder emails because of database connection error!</font>"
Call Send_Email(EmailFailure, strBody, "")
End IF
'=====================================================
' Functions and Subroutines
'=====================================================
Sub MailoutReminders()
' ADO for database
Dim oRs
Dim oCmd
Dim emailCount
Dim userCount
Dim strTo
Dim strCC
Dim strEmailSentToOnFail
emailCount = 0
userCount = 0
On Error Resume Next
Set oCmd=CreateObject("ADODB.Command")
Set oRs=CreateObject("ADODB.Recordset")
' failure notification
If Err.number<>0 Then
Err.Clear
strBody = "<font face=Tahoma color=red size=3pt>Unable to send time entry reminder emails -- Creating ADO objects failed!</font>"
Call Send_Email(EmailFailure, strBody, "")
Exit Sub
End If
oCmd.ActiveConnection = oCon
oCmd.CommandType = adCmdStoredProc
oCmd.CommandText = "p_time_entry_email_reminder"
Set oRs=oCmd.Execute
' failure notification
If Err.number<>0 Then
Err.Clear
strBody = "<font face=Tahoma color=red size=3pt>Unable to send time entry reminder emails -- Executing stored procedure p_time_entry_email_reminder failed!</font>"
Call Send_Email(EmailFailure, strBody, "")
Exit Sub
End If
' storedproc execution successful
If Not oRs.EOF Then
While Not oRs.EOF
userCount = userCount + 1
If blnDebugOn Then
strTo = EmailDebug
Else
strTo = oRs("Email")
strCC = "usermanager@company.com"
End If
strBody = Email_Template(oRs("FirstName"),oRs("LastName"))
If Err.number=0 Then
Call Send_Email(strTo, strBody, strCC)
If Err.number=0 Then
emailCount = emailCount + 1
If Err.number<>0 Then
strEmailSentToOnFail = strEmailSentToOnFail & "/" & oRs("Userid")
Err.Clear
End If
Else
Err.Clear
End If
Else
Err.Clear
End If
oRs.MoveNext
Wend
End If
oRs.Close
' successful email
strBody = emailCount & " of " & userCount & " time entry reminding email(s) have been sent on " & date() & " at " & time() & ".<br>"
Call Send_Email(EmailSuccess, strBody, EmailCC)
' failure notification
If (emailCount <> userCount) or (strEmailSentToOnFail<>"") Then
strBody = "<table border=""0"" width=""500""><tr><td><font face=Tahoma color=red size=3pt>"
strBody = strBody & "Total emails should be sent: " & userCount & "<br>"
strBody = strBody & "Number of emails actually sent: " & emailCount & "<br><br>"
If strEmailSentToOnFail<>"" Then
strBody = strBody & "Reminding emails have been sent to the following users:<br>"
strBody = strBody & strEmailSentToOnFail & "<br><br>"
End If
strBody = strBody & "</font></td></tr></table>"
Call Send_Email(EmailFailure, strBody, "")
End If
End Sub
'function to open db connection
Function OpenConnection()
' assume failure
OpenConnection = false
On Error Resume Next
Set oCon=CreateObject("ADODB.Connection")
If Err.number <> 0 Then
Err.Clear
Exit Function
End If
oCon.ConnectionString = strDBConnection
oCon.Open
If Err.number <> 0 Then
Err.Clear
Exit Function
End If
OpenConnection = true
End Function
'sub to close db connection
Sub CloseConnection()
oCon.Close
Set oCon = nothing
End Sub
'function to invoke cdonts
Sub Send_Email(sendTo, contents, ccTo)
Dim objSendMail
' create and initialize mail object
Set objSendMail = CreateObject("CDONTS.NewMail")
objSendMail.From = strFrom
objSendMail.To = sendTo
If ccTo <> "" Then
objSendMail.CC = ccTo
End If
objSendMail.Subject = strSubject
objSendMail.Body = contents
objSendMail.BodyFormat = CdoBodyFormatHTML
objSendMail.MailFormat = CdoMailFormatMime
objSendMail.Importance = CdoHigh
objSendMail.send
Set objSendMail = Nothing
End Sub
'=======================================================================================
' email template
'=======================================================================================
Function Email_Template(FirstName,LastName)
Email_Template = "<font face=""Arial, Helvetica, sans-serif"" size=""3"">"
Email_Template = Email_Template & "<table border=0 cellpadding=1 cellspacing=1>"
Email_Template = Email_Template & "<tr><td>"
Email_Template = Email_Template & "" & FirstName & " " & LastName & "<br><br>"
Email_Template = Email_Template & "blah blah blah blah.<br><br>"
Email_Template = Email_Template & "</td></tr>"
Email_Template = Email_Template & "</table>"
Email_Template = Email_Template & "</font>"
End Function
