VBScript password change email error - vbscript

Question

Apologies in advance for any incorrect terminology (I am a PC Tech, not a developer/programmer).
We have a VBScript running in one of our servers to send an email notice to users that their Windows password will expire and they need to change it. The script is as follows:
*******************Begin Code*****
on error resume next
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D
Const ONE_HUNDRED_NANOSECOND = .000000100
Const SECONDS_IN_DAY = 86400
strDomainDN = "DomainNameHere" 'Domain name here - both Netbios and DNS style names should work
ReminderAge = 10 'Days before the reminders start being sent
'strbody - Body of the message being sent
strbody = "This message is a reminder that your password will be expiring soon." & vbcrlf
strbody = strbody & "Please change your network password before the date listed above to avoid being locked out of the system." & vbcrlf
strbody = strbody & "If you need instructions on how to change your password please contact:" & vbcrlf
strbody = strbody & "the IT Department" & vbcrlf
strbody = strbody & vbcrlf & "Thank you," & vbcrlf
strbody = strbody & "IT Department"
'create logfile
Set objFSO = CreateObject("Scripting.FileSystemObject")
strScriptPath = objfso.GetParentFolderName(WScript.ScriptFullName)
strLogName = TwoDigits(Year(now)) & TwoDigits(Month(now)) & TwoDigits(Day(now)) & TwoDigits(Hour(now)) & TwoDigits(Minute(now)) &
TwoDigits(Second(now)) & ".txt"
strLogFile = strScriptPath & "Logs\" & StrLogName
Set objLogFile = objFSO.CreateTextFile(strLogFile,1)
objLogfile.Writeline "Email Password Check Script started: " & Now
Dim rootDSE,domainObject
Set rootDSE = GetObject("LDAP://RootDSE")
Set oDomain = GetObject("LDAP://" & strDomainDN)
Set maxPwdAge = oDomain.Get("maxPwdAge")
DomainContainer = rootDSE.Get("defaultNamingContext")
Set fs = CreateObject ("Scripting.FileSystemObject")
Set conn = CreateObject("ADODB.Connection")
conn.Provider = "ADSDSOObject"
conn.Open "ADs Provider"
numDays = CCur((maxPwdAge.HighPart * 2 ^ 32) + maxPwdAge.LowPart) / CCur(-864000000000)
'LDAP string to only find user accounts with mailboxes
ldapStr = "<LDAP://" & DomainContainer & ">;(& (mailnickname=*) (|
(&(objectCategory=person)(objectClass=user)(!(homeMDB=*))(!(msExchHomeServerName=*)))(&(objectCategory=person)(objectClass=user)(|(homeMDB=*)(msExchHomeServerName=*))) ));adspath;subtree"
Set rs = conn.Execute(ldapStr)
While Not rs.EOF
Set oUser = GetObject (rs.Fields(0).Value)
dtmValue = oUser.PasswordLastChanged
If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then
whenpasswordexpires = "The password has never been set."
else
whenPasswordExpires = DateAdd("d", numDays, oUser.PasswordLastChanged)
end if
daysb4expire = Int(whenPasswordExpires - Now)
'write user info to logfile
objLogfile.Writeline "-----------------------------------------"
objLogfile.Writeline "SAM Acct: " & oUser.SamAccountName
objLogfile.Writeline "Disp Name: " & oUser.displayName
objLogfile.Writeline "UPN: " & oUser.userprincipalname
objLogfile.Writeline "PW Changed: " & oUser.PasswordLastChanged
objLogfile.Writeline "PW Expires: " & whenPasswordExpires
dblMaxPwdNano = Abs(MaxPwdAge.HighPart * 2^32 + MaxPwdAge.LowPart)
dblMaxPwdSecs = dblMaxPwdNano * ONE_HUNDRED_NANOSECOND
dblMaxPwdDays = Int(dblMaxPwdSecs / SECONDS_IN_DAY)
objLogfile.Writeline "The password will expire on " & _
DateValue(dtmValue + dblMaxPwdDays) & " (" & _
Int((dtmValue + dblMaxPwdDays) - Now) & " days from today)."
if daysb4expire < ReminderAge and daysb4expire > 0 then
objLogfile.Writeline "Expiring soon - sending eMail"
objLogfile.Writeline "*****************************"
strNoteMessage = "Dear " & oUser.displayName & "," & vbcrlf & vbcrlf
strNoteMessage = strNoteMessage & "Your Network password will expire on " & _
DateValue(dtmValue + dblMaxPwdDays) & " (" & _
Int((dtmValue + dblMaxPwdDays) - Now) & " days from today)." & vbcrlf & vbcrlf
Set objEmail = CreateObject("CDO.Message")
objEmail.From = "me#myCompany.com" 'Your From Address
objEmail.To = oUser.userprincipalname
objEmail.Subject = "Network Password Expiration Notice" 'Message subject
objEmail.TextBody = strNoteMessage & strBody
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") =
"YOUREXCHANGE.SERVER.DomainName.COM" ' Your mailserver here
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update
'objEmail.Send 'commented out right now---so you won't send out the email.
End If
set whenpasswordexpires = nothing
err.clear
rs.MoveNext
Wend
Set oUser = Nothing
Set maxPwdAge = Nothing
Set oDomain = Nothing
Logfile.Close
Function TwoDigits(t)
TwoDigits = Right("00" & t,2)
End Function
WScript.quit
Obviously I removed our info from the script for this post.
The errors are that:
It does not send an email everyday if the user does not change their password for a few days. It sends them randomly.
A few random users, if they have not changed their password, around the 5th or 6th day will start getting hundreds of thousands of emails in just a few seconds, completely locking down Outlook on their computer. If they change the password they stop getting them (obviously).
Is there something I'm missing or need to remove from this script to get it to at least stop sending so many emails at once?
Thank you.

Answer 1

A couple of ideas to help you track down the problem.
Only have on error resume next before the command that needs it oUser.PasswordLastChanged, after that line on error goto 0 Then run the script manually and you'll have a better chance of finding some statement that is failing. update - should store the value in a variable and use
Get consistent with what variables are for. whenpasswordexpires is set to text in one part of the if err.number and a date in the other. It's then used as a date to calculate days and finally set whenpasswordexpires = nothing treats it like an object. This could mean some of your if statements are erroring and just going to the next line, instead of skipping the if - so people might be getting mailed when they shouldn't.
Consider calculating a date to pass to the LDAP query and only return people to be emailed - instead of going through all users all the time
(without ever having much to do with LDAP queries) I think your current query simplifies down to ldapStr = "<LDAP://" & DomainContainer & ">;(& (mailnickname=*)(objectCategory=person)(objectClass=user));adspath;subtree" all the ors and ands with homeMDB and msExchHomeServerName would seem to mean any combination is included. It's probably worth running your query in an LDAP explorer tool to check you're really getting what you want.
LDAP often has a limit of the number of records returned, so you might be erroring all the time because you get more than 1000 (typical) records returned. This can be worked around by getting data in smaller pages (say 250).
Logging to a new file each time may hide issues from you, e.g if the task is restarted by scheduler. Much easier to diagnose if there is just one log per day. You also don't close the log file correctly - should be objLogFile.Close (not logfile.Close). You aren't putting the log in a subdirectory of the scripts folder (e.g. scripts & scripts\logs) but at the same level (e.g. scripts & scriptsLogs)
The logfile not objLogFile issue highlights why it is best to put Option Explicit at the top of your code. This means you have to dim every variable that you use, which can be a pain to do, but ensures that you don't have typos in your variable names which can cause you massive headaches.
The WScript.Quit is the very last line, so won't do anything - the codes about to finish anyway. If you ever want to abort the execution of script, the WScript.Quit needs to where you want to abort from - normally within some if statement.
There are a number of repeated calculations... days, dtmValue + dblMaxPwdDays, etc. I just mention this as it makes the code harder to read and therefore harder to understand what might be wrong.
All that said, I've probably made too many comments now for you to really comprehend without me just making the changes and posting updated script for you to try.
See if this version runs error free for you...
option explicit
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
Const E_ADS_PROPERTY_NOT_FOUND = &h8000500D
Const ONE_HUNDRED_NANOSECOND = .000000100
Const SECONDS_IN_DAY = 86400
Dim strDomainDN, strBody, strNoteMessage
Dim objFSO, objLogFile, objEmail
Dim strScriptPath, strLogName, strLogFile
strDomainDN = "DomainNameHere" 'Domain name here - both Netbios and DNS style names should work
Const ReminderAge = 10 'Days before the reminders start being sent
'strbody - Body of the message being sent
strbody = "This message is a reminder that your password will be expiring soon." & vbcrlf
strbody = strbody & "Please change your network password before the date listed above to avoid being locked out of the system." & vbcrlf
strbody = strbody & "If you need instructions on how to change your password please contact:" & vbcrlf
strbody = strbody & "the IT Department" & vbcrlf
strbody = strbody & vbcrlf & "Thank you," & vbcrlf
strbody = strbody & "IT Department"
'create logfile
Set objFSO = CreateObject("Scripting.FileSystemObject")
strScriptPath = objfso.GetParentFolderName(WScript.ScriptFullName)
strLogName = TwoDigits(Year(now)) & TwoDigits(Month(now)) & TwoDigits(Day(now)) & ".txt"
strLogFile = strScriptPath & "Logs\" & StrLogName
Set objLogFile = objFSO.OpenTextFile(strLogFile, 8, True)
objLogFile.Writeline "Email Password Check Script started: " & Now
Dim rootDSE, oDomain, DomainContainer
Dim maxPwdAge, numDays
Dim conn, command
Dim ldapStr
Dim rs, oUser, passwordChanged, whenPasswordExpires, daysb4expire
Set rootDSE = GetObject("LDAP://RootDSE")
Set oDomain = GetObject("LDAP://" & strDomainDN)
Set maxPwdAge = oDomain.Get("maxPwdAge")
DomainContainer = rootDSE.Get("defaultNamingContext")
Set conn = CreateObject("ADODB.Connection")
Set command = CreateObject("ADODB.Command")
conn.Provider = "ADSDSOObject"
conn.Open "ADs Provider"
Set command.ActiveConnection = conn
command.Properties("Page Size") = 250
numDays = ABS(CCur((maxPwdAge.HighPart * 2 ^ 32) + maxPwdAge.LowPart) / CCur(864000000000))
'LDAP string to only find user accounts with mailboxes
Dim dteCnv, sec1601, strExpireDate, strRemindDate
dteCnv = DateAdd("d", -numDays, Now)
sec1601 = DateDiff("s","1/1/1601",dteCnv)
strExpireDate = CStr(sec1601) & "0000000"
dteCnv = DateAdd("d", ReminderAge - numDays, Now)
sec1601 = DateDiff("s","1/1/1601",dteCnv)
strRemindDate = CStr(sec1601) & "0000000"
ldapStr = "<LDAP://" & DomainContainer & ">;(& (mailnickname=*)(objectCategory=person)(objectClass=user)(pwdLastSet>=" & strExpireDate & ")(pwdLastSet<=" & strRemindDate & "));adspath;subtree"
command.CommandText = ldapStr
Set rs = command.Execute
While Not rs.EOF
Set oUser = GetObject (rs.Fields(0).Value)
on error resume next
passwordChanged = oUser.PasswordLastChanged
If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then
passwordChanged = "Never"
whenPasswordExpires = Now
elseIf Err.Number <> 0 Then
passwordChanged = "Unknown - " & Err.Description
whenPasswordExpires = Now
else
whenPasswordExpires = DateAdd("d", numDays, passwordChanged)
end if
on error goto 0
daysb4expire = Int(whenPasswordExpires - Now)
'write user info to logfile
objLogFile.Writeline "-----------------------------------------"
objLogFile.Writeline "SAM Acct: " & oUser.SamAccountName
objLogFile.Writeline "Disp Name: " & oUser.displayName
objLogFile.Writeline "UPN: " & oUser.userprincipalname
objLogFile.Writeline "PW Changed: " & passwordChanged
objLogFile.Writeline "PW Expires: " & whenPasswordExpires
objLogFile.Writeline "The password will expire on " & whenPasswordExpires & " (" & daysb4expire & " days from today)."
if daysb4expire <= ReminderAge and daysb4expire > 0 then
objLogFile.Writeline "Expiring soon - sending eMail"
objLogFile.Writeline "*****************************"
strNoteMessage = "Dear " & oUser.displayName & "," & vbcrlf & vbcrlf
strNoteMessage = strNoteMessage & "Your Network password will expire on " & whenPasswordExpires & " (" & daysb4expire & " days from today)." & vbcrlf & vbcrlf
Set objEmail = CreateObject("CDO.Message")
objEmail.From = "me#myCompany.com" 'Your From Address
objEmail.To = oUser.userprincipalname
objEmail.Subject = "Network Password Expiration Notice" 'Message subject
objEmail.TextBody = strNoteMessage & strBody
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "YOUREXCHANGE.SERVER.DomainName.COM" ' Your mailserver here
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objEmail.Configuration.Fields.Update
'objEmail.Send 'commented out right now---so you won't send out the email.
End If
err.clear
rs.MoveNext
Wend
Set oUser = Nothing
Set maxPwdAge = Nothing
Set oDomain = Nothing
objLogFile.Writeline "Email Password Check completed: " & Now & vbcrlf & vbcrlf
objLogFile.Close
Function TwoDigits(t)
TwoDigits = Right("00" & t,2)
End Function