Password Expiration LDAP script?

Discussion in 'Scripting' started by Tom, Jul 14, 2009.

  1. Tom

    Tom Guest

    We host email for about a dozen remote locations. Since these users never
    actually log into our network except for email (RPC over HTTPS & OWA), they
    are never notified that their password is set to expire.

    Is there a query that can be run on an OU that gathers the password
    expiration dates for users? I can then take that data and script email
    notifications.

    Thanks,
    Tom
     
    Tom, Jul 14, 2009
    #1
    1. Advertisements

  2. I have an example VBScript program that determines when the password was
    last set for all users in the domain linked here:

    http://www.rlmueller.net/PwdLastChanged.htm

    This program can be modified to only deal with users in a specified OU. It
    can also be revised to calculate when the password for each user will
    expire, assuming a specified domain maximum password age policy. For
    example:
    ============
    ' VBScript program to determine when passwords expire
    ' for users in a specified OU.
    Option Explicit

    Const ADS_UF_PASSWD_CANT_CHANGE = &H40
    Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000

    Dim strFilePath, objFSO, objFile, adoConnection, adoCommand
    Dim strFilter, strQuery, adoRecordset
    Dim strDN, objShell, lngBiasKey, lngBias, blnPwdExpire
    Dim objDate, dtmPwdLastSet, lngFlag, k
    Dim lngMaxPwdAge, dtmPwdExpires

    ' Specify maximum password age policy in days.
    lngMaxPwdAge = 42

    ' Check for required arguments.
    If (Wscript.Arguments.Count < 1) Then
    Wscript.Echo "Arguments <FileName> required. For example:" & vbCrLf _
    & "cscript PwdLastChanged.vbs c:\MyFolder\UserList.txt"
    Wscript.Quit(0)
    End If

    strFilePath = Wscript.Arguments(0)
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    ' Open the file for write access.
    On Error Resume Next
    Set objFile = objFSO.OpenTextFile(strFilePath, 2, True, 0)
    If (Err.Number <> 0) Then
    On Error GoTo 0
    Wscript.Echo "File " & strFilePath & " cannot be opened"
    Set objFSO = Nothing
    Wscript.Quit(1)
    End If
    On Error GoTo 0

    ' Obtain local time zone bias from machine registry.
    Set objShell = CreateObject("Wscript.Shell")
    lngBiasKey = objShell.RegRead("HKLM\System\CurrentControlSet\Control\" _
    & "TimeZoneInformation\ActiveTimeBias")
    If (UCase(TypeName(lngBiasKey)) = "LONG") Then
    lngBias = lngBiasKey
    ElseIf (UCase(TypeName(lngBiasKey)) = "VARIANT()") Then
    lngBias = 0
    For k = 0 To UBound(lngBiasKey)
    lngBias = lngBias + (lngBiasKey(k) * 256^k)
    Next
    End If

    ' Use ADO to search the domain for all users.
    Set adoConnection = CreateObject("ADODB.Connection")
    Set adoCommand = CreateObject("ADODB.Command")
    adoConnection.Provider = "ADsDSOOBject"
    adoConnection.Open "Active Directory Provider"
    Set adoCommand.ActiveConnection = adoConnection

    ' Filter to retrieve all user objects.
    strFilter = "(&(objectCategory=person)(objectClass=user))"

    ' Specify DN of OU as base of query.
    strQuery = "<LDAP://ou=West,dc=MyDomain,dc=com>;" & strFilter _
    & ";distinguishedName,pwdLastSet,userAccountControl;subtree"

    adoCommand.CommandText = strQuery
    adoCommand.Properties("Page Size") = 100
    adoCommand.Properties("Timeout") = 30
    adoCommand.Properties("Cache Results") = False

    ' Enumerate all users. Write each user's Distinguished Name,
    ' whether they are allowed to change their password, and when
    ' they last changed their password to the file.
    Set adoRecordset = adoCommand.Execute
    Do Until adoRecordset.EOF
    strDN = adoRecordset.Fields("distinguishedName").Value
    lngFlag = adoRecordset.Fields("userAccountControl").Value
    blnPwdExpire = True
    If ((lngFlag And ADS_UF_PASSWD_CANT_CHANGE) <> 0) Then
    blnPwdExpire = False
    End If
    If ((lngFlag And ADS_UF_DONT_EXPIRE_PASSWD) <> 0) Then
    blnPwdExpire = False
    End If
    Set objDate = adoRecordset.Fields("pwdLastSet").Value
    dtmPwdLastSet = Integer8Date(objDate, lngBias)
    If (blnPwdExpire = True) Then
    dtmPwdExpires = DateAdd("d", lngMaxPwdAge, dtmPwdLastSet)
    objFile.WriteLine strDN & ";" & blnPwdExpire _
    & ";" & dtmPwdLastSet & ";" & dtmPwdExpires
    Else
    objFile.WriteLine strDN & ";" & blnPwdExpire _
    & ";" & dtmPwdLastSet & ";" & "<Never>"
    End If
    adoRecordset.MoveNext
    Loop
    adoRecordset.Close

    ' Clean up.
    objFile.Close
    adoConnection.Close

    Wscript.Echo "Done"

    Function Integer8Date(ByVal objDate, ByVal lngBias)
    ' Function to convert Integer8 (64-bit) value to a date, adjusted for
    ' local time zone bias.
    Dim lngAdjust, lngDate, lngHigh, lngLow
    lngAdjust = lngBias
    lngHigh = objDate.HighPart
    lngLow = objdate.LowPart
    ' Account for bug in IADslargeInteger property methods.
    If (lngLow < 0) Then
    lngHigh = lngHigh + 1
    End If
    If (lngHigh = 0) And (lngLow = 0) Then
    lngAdjust = 0
    End If
    lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) _
    + lngLow) / 600000000 - lngAdjust) / 1440
    Integer8Date = CDate(lngDate)
    End Function
     
    Richard Mueller [MVP], Jul 14, 2009
    #2
    1. Advertisements

  3. Hi Tom,

    I have such a script. You will want to edit the SMTP server
    information and from address to match your network. Put this script on
    a DC and have it run as a scheduled task daily early in the morning.
    It will query for passwords that need to be changed and send an email
    to the user.

    Code:
    '=======================================================================
    ===
    '
    ' NAME: NotifyPasswordExpireOWA.vbs
    '
    ' AUTHOR: Mark D. MacLachlan , The Spider's Parlor
    ' DATE  : 04/15/2003
    '
    ' COMMENT:
    ' Schedule to notify users that password will expire soon.
    ' This script should be run from the Exchange Server as a scheduled
    task.
    '
    '    THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF
    '    ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED To
    '    THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A
    '    PARTICULAR PURPOSE.
    '
    '    IN NO EVENT SHALL THE SPIDER'S PARLOR AND/OR ITS RESPECTIVE
    SUPPLIERS
    '    BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY
    '    DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
    '    WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
    '    ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
    '    OF THIS CODE OR INFORMATION.
    '
    '=======================================================================
    ===
    
    '=============================
    ' First enumerate through users
    ' strComputer must be a Domain Controller, use "." for local
    ' or specify a remote server name within the quotes.
    '=============================
    strComputer = "."
    Set objWMIService = GetObject("winmgmts:\\" & strComputer &
    "\root\CIMV2")
    Set colItems = objWMIService.ExecQuery("SELECT * FROM
    Win32_UserAccount",,48)
    
    For Each objItem In colItems
    strSAM = objItem.Name
    strLDAP = SearchDistinguishedName(objItem.Name)
    Set objUser = GetObject("LDAP://" & strLDAP)
    strUserMail = objUser.mail
    'Now check for the expiration
    Check = CheckExpiration(strLDAP, strUserMail)
    Set ObjUser = Nothing
    Next
    
    
    
    
    Function CheckExpiration(strUserDN, UserEmail)
    '========================================
    ' This section of the script will check the users password for
    expiration
    ' First, get the domain policy.
    '========================================
    Dim oDomain, oUser,maxPwdAge, numDays, daysToExpiration
    
    Set sys = CreateObject("ADSystemInfo")
    strDomainDN =  sys.DomainShortName
    
    Set oDomain = GetObject("LDAP://" & strDomainDN)
    Set maxPwdAge = oDomain.Get("maxPwdAge")
    
    '========================================
    ' Calculate the number of days that are
    ' held in this value.
    '========================================
    numDays = CCur((maxPwdAge.HighPart * 2 ^ 32) + _
    maxPwdAge.LowPart) / CCur(-864000000000)
    WScript.Echo "Maximum Password Age: " & numDays
    
    '========================================
    ' Determine the last time that the user
    ' changed his or her password.
    '========================================
    Set oUser = GetObject("LDAP://" & strUserDN)
    
    '========================================
    ' Add the number of days to the last time
    ' the password was set.
    '========================================
    whenPasswordExpires = DateAdd("d", numDays,
    oUser.PasswordLastChanged)
    
    '========================================
    ' Now get the number of days until expiration
    '========================================
    daysToExpiration = DateDiff("d", Now(),whenPasswordExpires)
    
    '========================================
    ' Send the email if expiration is within parameters
    '========================================
    If daysToExpiration <= 10 Then
    NotifyExpiration(UserEmail)
    End If
    
    '========================================
    ' Clean up.
    '========================================
    Set oUser = Nothing
    Set maxPwdAge = Nothing
    Set oDomain = Nothing
    
    End Function
    
    
    
    
    Function NotifyExpiration(oTo)
    '=====================================
    ' You must customize the entry for oMyIP (your SMTP server address)
    with the proper company information.
    '=====================================
    
    Dim oName, ODomain, oMyIP, sys
    Set sys = CreateObject("ADSystemInfo")
    'Below will use the AD DNS name for the email automatically or you can
    'specifically set the value if the email domain is different.
    ODomain = sys.DomainDNSName
    ' Company Internet Domain Name Uncomment next line and change value if
    desired.
    'ODomain = "YOURCOMPANY.com"
    
    ' Set the SMTP server IP
    oMyIP = "192.168.1.2"
    
    
    ' Set the visual basic constants as they do not exist within VBScript.
    ' Do not set your smtp server information here.
    Const cdoSendUsingMethod =
    "http://schemas.microsoft.com/cdo/configuration/sendusing", _
    cdoSendUsingPort = 2, _
    cdoSMTPServer =
    "http://schemas.microsoft.com/cdo/configuration/smtpserver"
    
    'Create the CDO connections.
    Dim iMsg, iConf, Flds
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    Set Flds = iConf.Fields
    
    'SMTP server configuration.
    With Flds
    .Item(cdoSendUsingMethod) = cdoSendUsingPort
    
    'Set the SMTP server address here.
    .Item(cdoSMTPServer) = oMyIP
    .Update
    End With
    
    'Set the message properties.
    With iMsg
    Set .Configuration = iConf
    .To = oTo
    .From = oName & "@" & oDomain
    .Subject = "Password About To Expire"
    .TextBody = "This is a reminder that you must change your password.
    To avoid being locked out, change your password now."
    End With
    
    'An attachment can be included.
    'iMsg.AddAttachment Attachment
    
    'Send the message.
    iMsg.Send
    End Function
    
    Public Function SearchDistinguishedName(ByVal vSAN)
    ' Function:     SearchDistinguishedName
    ' Description:  Searches the DistinguishedName for a given
    SamAccountName
    ' Parameters:   ByVal vSAN - The SamAccountName to search
    ' Returns:      The DistinguishedName Name
    Dim oRootDSE, oConnection, oCommand, oRecordSet
    
    Set oRootDSE = GetObject("LDAP://rootDSE")
    Set oConnection = CreateObject("ADODB.Connection")
    oConnection.Open "Provider=ADsDSOObject;"
    Set oCommand = CreateObject("ADODB.Command")
    oCommand.ActiveConnection = oConnection
    oCommand.CommandText = "<LDAP://" &
    oRootDSE.get("defaultNamingContext") & _
    ">;(&(objectCategory=User)(samAccountName=" & vSAN &
    "));distinguishedName;subtree"
    Set oRecordSet = oCommand.Execute
    On Error Resume Next
    SearchDistinguishedName = oRecordSet.Fields("DistinguishedName")
    On Error GoTo 0
    oConnection.Close
    Set oRecordSet = Nothing
    Set oCommand = Nothing
    Set oConnection = Nothing
    Set oRootDSE = Nothing
    End Function
    
    Hope that helps,

    Mark D. MacLachlan
    --
     
    Mark D. MacLachlan, Jul 15, 2009
    #3
  4. Tom

    Tom Guest

    Thank you very much!!

    Tom




     
    Tom, Jul 16, 2009
    #4
  5. Happy to assist.

    Regards,

    Mark
    --
     
    Mark D. MacLachlan, Jul 18, 2009
    #5
    1. Advertisements

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments (here). After that, you can post your question and our members will help you out.