'Define constants
Const SEC_IN_DAY = 86400
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
Const ADS_UF_ACCOUNTDISABLE = 2
Const crlf="<BR>"
'Define global variables
Dim txtOutput, binFirstWindow, intMaxPwdAge, iDaysExpire, showTextWindow, strSMTPFrom, strSMTPRelay
Dim objExplorer, rootDSE, domainObject, userObject, userFile, numLines
Dim arrTextLine(9)
ReDim arrBody(1)
'Run Subroutines
runSetup
getExpiredUsers(domainObject)
runExit
wscript.echo "Done!"
Sub getExpiredUsers(oObject)
On Error Resume Next
'Dim oUser
For Each oUser in oObject
Select Case oUser.Class
Case "user"
usrName = oUser.displayName
usrLoc = Replace(oUser.distinguishedName, "\", "")
Set objUserLDAP = GetObject("LDAP://" & oUser.distinguishedName)
intCurrentValue = objUserLDAP.Get("userAccountControl")
If intCurrentValue AND ADS_UF_ACCOUNTDISABLE Then
usrStatus = "User is disabled"
Else
If intCurrentValue and ADS_UF_DONT_EXPIRE_PASSWD Then
usrStatus = "The password does not expire."
Else
dtmValue = objUserLDAP.PasswordLastChanged
If Err.Number <> 0 then
usrStatus = "Error: user may not have changed password"
Err.Clear
Else
usrDate = dtmValue
intTimeInterval = int(now - dtmValue)
If intMaxPwdAge < 0 Then
usrLeft = 0
usrExpiredDate = ""
usrStatus = "Password does not expire"
Else
intMaxInSec = (intMaxPwdAge / SEC_IN_DAY)
If intTimeInterval >= intMaxInSec Then
usrLeft = 0
usrExpiredDate = DateValue(dtmValue + intMaxInSec)
usrStatus = "Password has expired"
Else
usrLeft = int((dtmValue + intMaxInSec) - Now)
usrExpiredDate = DateValue(dtmValue + intMaxInSec)
If usrLeft <= iDaysExpire Then
strResult = sendUserMail(oUser.givenName, oUser.sn, oUser.mail, usrLeft)
usrStatus = "Expiring in " & usrLeft & " days! " & strResult
Else
usrStatus = "Not expired"
End If
End If
End If
End If
End If
End If
userFile.Write chr(34) & usrName & chr(34) & "," & chr(34) & usrLoc & chr(34) & "," & usrDate & "," & usrLeft & "," & usrExpiredDate & "," & chr(34) & usrStatus & chr(34)
userFile.WriteLine ""
Case "organizationalUnit" , "container"
txtOU = oUser.distinguishedName
txtOU = right(txtOU, len(txtOU)-3)
txtOU = left(txtOU, instr(txtOU, ",") - 1)
showtext("Now looking in " & txtOU & "...")
getExpiredUsers(oUser)
End Select
Next
End Sub
Sub ShowText(txtInput)
If showTextWindow = True then
If binFirstWindow = True then
objExplorer.Navigate "about:blank"
objExplorer.ToolBar = 0
objExplorer.StatusBar = 0
objExplorer.Width=400
objExplorer.Height = 300
objExplorer.Left = 200
objExplorer.Top = 200
Do While (objExplorer.Busy)
Wscript.Sleep 200
Loop
objExplorer.Visible = 1
binFirstWindow = False
End If
intTop = UBound(arrTextLine)
For z = 0 to intTop - 1
arrTextLine(z) = arrTextLine(z + 1)
Next
arrTextLine(intTop) = txtInput
For z = 0 to intTop
strText = strText & "<BR>" & arrTextLine(z)
Next
objExplorer.Document.Body.InnerHTML = strText
End If
End Sub
Sub runSetup
Set rootDSE=GetObject("LDAP://RootDSE")
domainContainer = rootDSE.Get("defaultNamingContext")
Set domainObject = GetObject("LDAP://" & domainContainer)
Set oNetwork = CreateObject("WScript.Network")
domain = oNetwork.UserDomain
Set oDomainNT = GetObject("WinNT://" & domain)
intMaxPwdAge = oDomainNT.Get("MaxPasswordAge")
Set fs = CreateObject ("Scripting.FileSystemObject")
If fs.FileExists(".\ExpiredPasswords.csv") Then
fs.DeleteFile(".\ExpiredPasswords.csv")
End If
Set userFile = fs.CreateTextFile (".\ExpiredPasswords.csv")
userFile.Write "UserName, UserDN, LastPasswordChangeDate, DaysUntilExpired, DateOfExpire, UserStatus"
userFile.WriteLine
'Parse the INI file
Set readFile = fs.OpenTextFile (".\EmailExpiringPasswords.ini")
strMode = "SETUP"
Do Until readFile.AtEndOfStream
strLine = readFile.ReadLine
If strMode = "SETUP" Then
If InStr(strLine, "=") > 0 Then
strValue = Trim(Right(strLine, Len(strLine) - InStr(strLine, "=")))
Else
strValue = ""
End If
If UCase(Left(strLine, 9)) = "SMTPRELAY" Then
strSMTPRelay = strValue
End If
If UCase(Left(strLine, 8)) = "SMTPFROM" Then
strSMTPFrom = strValue
End If
If UCase(Left(strLine, 18)) = "SHOWPROGRESSWINDOW" Then
If strValue = "Yes" or strValue = "TRUE" or strValue = "1" Then
showTextWindow = TRUE
Else
showTextWindow = FALSE
End If
End If
If UCASE(Left(strLine, 12)) = "DAYSTOEXPIRE" Then
iDaysExpire = CInt(strValue)
End If
If UCase(Left(strLine, 12)) = "[EMAIL BODY]" Then
strMode = "BODY"
numLines = 0
End If
If UCase(Left(strLine, 7)) = "[SETUP]" Then
strMode = "SETUP"
End If
Else
numLines = numLines + 1
ReDim Preserve arrBody(numLines)
arrBody(numLines) = strLine & vbCRLF
End If
Loop
'Construct the progress window
If showTextWindow = True then
dim txtOutput
binFirstWindow = True
Set objExplorer = WScript.CreateObject("InternetExplorer.Application")
End If
End Sub
Function sendUserMail(strGivenName, strSN, strEmailAddress, iDays)
For x = 1 to numLines
strLine = arrBody(x)
strLine = Replace(strLine, "%DAYS%" , iDays)
strLine = Replace(strLine, "%FIRSTNAME%", strGivenName)
strLine = Replace(strLine, "%EMAILADDR%", strEmailAddress)
strLine = Replace(strLine, "%LASTNAME%", strSN)
strTextBody = strTextBody & strLine
Next
Set objMessage = CreateObject("CDO.Message")
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPRelay
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.Subject = "Your password is about to expire in " & iDays & " days!"
objMessage.From = strSMTPFrom
objMessage.To = "hoogteijling@bedrijf.nl"
'strEmailAddress
objMessage.TextBody = strTextBody
objMessage.Send
If Err.Number <> 0 then
strResult = "Failed to send Email"
Else
strResult = "Email sent to user"
End If
Err.Clear
sendUserMail = strResult
End Function
Sub runExit
showtext(crlf & "Finished!")
End Sub