expira_senha_mail.vbs

'**************************************************************************************   
'Script Name: ExpirationNotifier.vbs   
'Author     : Carlton Colter   
'Purpose    : To notify users of password expiration via E-Mail   
'Created    : 8/4/2008   
'Note       : Modification of Douglas Urbano 03/03/2013 Script:    
'             http://www.benway.net/2005/09/20/223/   
'   
' This script sends an email to the user when their password is about to expire.
'**************************************************************************************   
    
'**************************************************************************************   
' Per environment constants - you should change these!   
Const SMTP_SERVER  = "192.168.2.222" ' Address of my Exchange    
Const LDAPPATH     = "LDAP://domain.br/OU=IT,DC=domain,DC=com" ' 
Const DAYS_FOR_EMAIL  = 15 
   
' System Constants - do not change   
Const ONE_HUNDRED_NANOSECOND    = .000000100   ' .000000100 is equal to 10^-7   
Const SECONDS_IN_DAY            = 86400   
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000   
Const E_ADS_PROPERTY_NOT_FOUND  = &h8000500D   
   
Dim numDays, iResult   
Dim strDomainDN   
Dim objContainer
   
numdays = 45 'Maximum password age
   
If numDays > 0 Then   
  Set objContainer = GetObject (LDAPPATH)   
  ProcessOU objContainer, numDays   
  ProcessFolder objContainer, numDays   
  Set objContainer = Nothing   
End If   
   
WScript.Echo "Notification Complete"   
   
'**************************************************************************************   
Sub ProcessOU (OU, numDays)   
  Dim SubOU   
  ou.Filter = Array("OrganizationalUnit")   
   
  For Each SubOU in OU   
    ProcessOU SubOU, numDays   
    ProcessFolder SubOU, numDays   
  Next   
End Sub   
   
'**************************************************************************************   
Function UserIsExpired (objUser, iMaxAge, iDaysForEmail, iRes)   
 Dim intUserAccountControl, dtmValue, intTimeInterval   
 Dim strName
   
 On Error Resume Next   
 Err.Clear
   
 strName = Mid (objUser.Name, 4)   
 intUserAccountControl = objUser.Get ("userAccountControl")   
   
 If intUserAccountControl And ADS_UF_DONT_EXPIRE_PASSWD Then   
  UserIsExpired = False   
 Else   
  iRes = 0   
  dtmValue = objUser.PasswordLastChanged   
  If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then   
   UserIsExpired = True   
  Else   
   intTimeInterval = Int (Now - dtmValue)   
   
   If intTimeInterval >= iMaxAge Then   
    UserIsExpired = True   
   Else   
    iRes = Int ((dtmValue + iMaxAge) - Now)   
   
    If iRes <= iDaysForEmail Then   
     UserIsExpired = True   
    Else   
     UserIsExpired = False   
    End If   
   End If
   
  End If   
 End If   
End Function   
   
'**************************************************************************************   
Sub ProcessFolder (objContainer, iMaxPwdAge)   
 Dim objUser, iResult
   
 objContainer.Filter = Array ("User")   
   
 For each objUser in objContainer   
  If InStr(objUser.sAMAccountName,"$")=0 Then   
   If UserIsExpired (objUser, iMaxPwdAge, DAYS_FOR_EMAIL, iResult) Then   
     Call SendEmail (objUser, iResult)   
    End If   
  End If   
 Next   
End Sub   
   
'**************************************************************************************   
Sub SendEmail (objUser, iResult)   
On Error Resume Next 'Ignore All Errors   
If iResult > 0 Then   
If LEN(objUser.givenname)>1 Then   
 Dim objMail
   
 Set objMail = CreateObject ("CDO.Message")   
   
 With objMail.Configuration.Fields   
  .Item ("http://schemas.microsoft.com/cdo/configuration/sendusing")      = 2   
  .Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver")     = SMTP_SERVER   
  .Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25   
  .Update   
 End With
   
 ' Make it a high priority   
 With objMail.Fields   
  .Item("urn:schemas:mailheader:X-MSMail-Priority") = "High" ' For Outlook 2003   
  .Item("urn:schemas:mailheader:X-Priority") = 2 ' For Outlook 2003 also   
  .Item("urn:schemas:httpmail:importance") = 2 ' For Outlook Express   
  .Update   
 End With
   
   
 ' Send the email to the user's userprincipal name (you can change this to .mail)   
 objMail.From     = objUser.UserPrincipalName 'STRFROM   
 objMail.To       = objUser.UserPrincipalName
   
 objMail.Subject  = "Automatic Password Expiration Notification"   
   
 objMail.Textbody = objUser.givenname & "," & vbCRLF & vbCRLF & _   
    "Your password will expire in " & iResult & " days. " & vbCRLF & vbCRLF & _   
    "It is important that you change your password or you will temporarily " & _   
    "lose access to your computer and email." & vbCRLF & vbCRLF & _   
    "SSL VPN users: To change your password while connected through " & _   
    "SSL VPN, press Ctrl + Alt + Delete on your keyboard and then click " & _   
    "Change Password." & vbCRLF & vbCRLF & _   
    "Passwords must meet the following criteria:" & vbCRLF & _   
    "       * Must not match the previous 2 passwords used. "  & vbCRLF & _   
    "       * At least 8 characters. "  & vbCRLF & _   
    "       * Does not contain your account or full name. " & vbCRLF & _   
    "       * Contains at least 1 uppercase character (A through Z)" & vbCRLF & _   
    "       * Contains at least 1 digit (0 through 9)" & vbCRLF & vbCRLF & _   
    "Do not reply to this email. If you have any questions or require additional" & _   
    "information, please contact Internal Systems at 1-555-555-1212" & vbCRLF & vbCRLF & _   
    "Thank you," & vbCRLF & vbCRLF & _   
    "Internal Systems"   
   
 objMail.Send
   
 Set objMail = Nothing
   
End If   
End If   
Err.Clear   
On Error Goto 0   
End Sub