We help IT Professionals succeed at work.

VBScript:  Machine Accounts about to Expire

itsmevic
itsmevic asked
on
Hi Experts!

     I'm curious, does anyone have in their script repository or know of the top of their a vbscript that I can use that will give me a "forecast" of machine account objects in Active Directory that are about to expire.  I have the perfect script I've attached below that gives me exactly what I'm wanting BUT for USER ACCOUNT objects.  If we could somehow tweak the below script to look for machine objects it would be absolutely PERFECT!  Thank you!  

     One of the cool things about the below script is that I can set it to however far out I want with the "intDays = 90" line, it then aligns everything beautifully in the body of an email.  It's GREATNESS!  : )
Option Explicit

Dim adoCommand, adoConnection, strBase, strFilter, strAttributes
Dim objRootDSE, strDNSDomain, strQuery, adoRecordset
Dim dtmDate1, dtmDate2, intDays, strName, strEmail
Dim lngSeconds1, str64Bit1, lngSeconds2, str64Bit2
Dim objShell, lngBiasKey, lngBias, k
Dim objDomain, objMaxPwdAge, lngHighAge, lngLowAge, sngMaxPwdAge
Dim objDate, dtmPwdLastSet, dtmExpires
Dim arrEmails, strItem, strPrefix
Dim strFilePath, objFSO, objFile
Dim objEmail, strSMTPServer, strEmailTo, strEmailFrom 
Dim intSMTPPort
Dim objReport

strEmailTo = "JaneSmith@abc.com, Rambo@abc.com"
strEmailFrom = "JohnDoe@abc.com"

strSMTPServer = "mailhost.abc.com"
intSMTPPort = 25

strFilePath = "Password_About_To_Expire_Report.csv"

' Specify number of days. Any users whose password expires within
' this many days after today will be processed.
intDays = 90

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"
    Wscript.Quit(1)
End If
On Error GoTo 0

objFile.WriteLine "sAMAccountName,displayName,UPN,Days to Expire,pwdLastSet"

' Determine domain maximum password age policy in days.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("DefaultNamingContext")
Set objDomain = GetObject("LDAP://" & strDNSDomain)
Set objMaxPwdAge = objDomain.MaxPwdAge

' Account for bug in IADslargeInteger property methods.
lngHighAge = objMaxPwdAge.HighPart
lngLowAge = objMaxPwdAge.LowPart
If (lngLowAge < 0) Then
    lngHighAge = lngHighAge + 1
End If
' Convert from 100-nanosecond intervals into days.
sngMaxPwdAge = -((lngHighAge * 2^32) _
    + lngLowAge)/(600000000 * 1440)

' Determine the password last changed date such that the password
' would just now be expired. We will not process users whose
' password has already expired.
dtmDate1 = DateAdd("d", - sngMaxPwdAge, Now())

' Determine the password last changed date such that the password
' will expire intDays in the future.
dtmDate2 = DateAdd("d", intDays - sngMaxPwdAge, Now())

' Obtain local Time Zone bias from machine registry.
' This bias changes with Daylight Savings Time.
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

' Convert the datetime values to UTC.
dtmDate1 = DateAdd("n", lngBias, dtmDate1)
dtmDate2 = DateAdd("n", lngBias, dtmDate2)

' Find number of seconds since 1/1/1601 for these dates.
lngSeconds1 = DateDiff("s", #1/1/1601#, dtmDate1)
lngSeconds2 = DateDiff("s", #1/1/1601#, dtmDate2)

' Convert the number of seconds to a string
' and convert to 100-nanosecond intervals.
str64Bit1 = CStr(lngSeconds1) & "0000000"
str64Bit2 = CStr(lngSeconds2) & "0000000"

Set objReport = CreateObject("Scripting.Dictionary")

' Setup ADO objects.
Set adoCommand = CreateObject("ADODB.Command")
Set adoConnection = CreateObject("ADODB.Connection")
adoConnection.Provider = "ADsDSOObject"
adoConnection.Open "Active Directory Provider"
Set adoCommand.ActiveConnection = adoConnection

' Search entire Active Directory domain.
strBase = "<LDAP://" & strDNSDomain & ">"

' Filter on user objects where the password expires between the
' dates specified, the account is not disabled, password never
' expires is not set, password not required is not set,
' and password cannot change is not set.
strFilter = "(&(objectCategory=person)(objectClass=user)" _
    & "(pwdLastSet>=" & str64Bit1 & ")" _
    & "(pwdLastSet<=" & str64Bit2 & ")" _
    & "(!userAccountControl:1.2.840.113556.1.4.803:=2)" _
    & "(!userAccountControl:1.2.840.113556.1.4.803:=65536)" _
    & "(!userAccountControl:1.2.840.113556.1.4.803:=32)" _
    & "(!userAccountControl:1.2.840.113556.1.4.803:=48))"

' Comma delimited list of attribute values to retrieve.
strAttributes = "distinguishedName,sAMAccountName,userPrincipalName,displayName,pwdLastSet"

' Construct the LDAP syntax query.
strQuery = strBase & ";" & strFilter & ";" & strAttributes & ";subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False

' Run the query.
Set adoRecordset = adoCommand.Execute

' Enumerate the resulting recordset.
Do Until adoRecordset.EOF
    ' Retrieve values.
    strName = adoRecordset.Fields("sAMAccountName").Value
    ' Determine when password expires.
    ' The pwdLastSet attribute should always have a value assigned,
    ' but other Integer8 attributes representing dates could be "Null".
    If (TypeName(adoRecordset.Fields("pwdLastSet").Value) = "Object") Then
        Set objDate = adoRecordset.Fields("pwdLastSet").Value
        dtmPwdLastSet = Integer8Date(objDate, lngBias)
    Else
        dtmPwdLastSet = #1/1/1601#
    End If
    dtmExpires = DateAdd("d", sngMaxPwdAge, dtmPwdLastSet)
    
    objFile.WriteLine """" & adoRecordset.Fields("sAMAccountName").Value & """,""" & _
                      adoRecordset.Fields("displayName").Value & """,""" & _
                      adoRecordSet.Fields("userPrincipalName").Value & """,""" & _
                      DateDiff("d", Now, dtmExpires) & """,""" & _
                      dtmPwdLastSet & """"
    
    dtmExpires = DateValue(dtmExpires)
    
    If (objReport.Exists(dtmExpires)) Then
      objReport(dtmExpires) = objReport(dtmExpires) + 1
    Else
      objReport(dtmExpires) = 1
    End If

    adoRecordset.MoveNext
Loop

' Clean up.
adoRecordset.Close
adoConnection.Close

objFile.Close
Set objFile = Nothing

SortDictionary(objReport)

Dim dtmDate, strSummary

strSummary = "# of Accounts     Date Password to Expire" & vbCrLf & _
             "*************     ***********************" & vbCrLf

For Each dtmDate In objReport.Keys
  strSummary = strSummary & CStr(objReport(dtmDate)) & Space(18 - Len(CStr(objReport(dtmDate)))) & CStr(dtmDate) & vbCrLf
Next

Set objEmail = CreateObject("CDO.Message")
objEmail.Subject = "90-Day Forecast - Upcoming Active Directory User Accounts Password Expirations"
objEmail.From = strEmailFrom
objEmail.To = strEmailTo
objEmail.TextBody = strSummary

objEmail.AddAttachment RegExGetBRef(WScript.ScriptFullName, "^(.+)\\[^\\]*$", 1, True) & "\" & strFilePath

objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 

'Name or IP of Remote SMTP Server
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPServer

'Server port (typically 25)
objEmail.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = intSMTPPort

objEmail.Configuration.Fields.Update

WScript.Echo strSummary

objEmail.Send

Const dictKey  = 1
Const dictItem = 2

Function SortDictionary(ByRef objDict)
  ' declare our variables
  Dim arrDict()
  Dim objKey
  Dim dtmKey, intItem
  Dim X,Y,Z

  ' get the dictionary count
  Z = objDict.Count

  ' we need more than one item to warrant sorting
  If Z > 1 Then
    ' create an array to store dictionary information
    ReDim arrDict(Z,2)
    X = 0
    ' populate the string array
    For Each objKey In objDict
        arrDict(X,dictKey)  = objKey
        arrDict(X,dictItem) = objDict(objKey)
        X = X + 1
    Next

    ' perform a a shell sort of the string array
    For X = 0 to (Z - 2)
      For Y = X to (Z - 1)
        If (arrDict(X, 1) > arrDict(Y, 1)) Then
          dtmKey  = arrDict(X,dictKey)
          intItem = arrDict(X,dictItem)
          arrDict(X,dictKey)  = arrDict(Y,dictKey)
          arrDict(X,dictItem) = arrDict(Y,dictItem)
          arrDict(Y,dictKey)  = dtmKey
          arrDict(Y,dictItem) = intItem
        End If
      Next
    Next
    
    ' erase the contents of the dictionary object
    objDict.RemoveAll
    
    ' repopulate the dictionary with the sorted information
    For X = 0 to (Z - 1)
      objDict.Add arrDict(X,dictKey), arrDict(X,dictItem)
    Next

  End If
End Function

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 error 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
    ' Trap error if lngDate is ridiculously huge.
    On Error Resume Next
    Integer8Date = CDate(lngDate)
    If (Err.Number <> 0) Then
        On Error GoTo 0
        Integer8Date = #1/1/1601#
    End If
    On Error GoTo 0
End Function

Function RegExGetBRef(strString, strPattern, intBRef, blnIgnoreCase)
  RegExGetBRef = ""
  
  Dim objRegExp
  Dim colMatches, objMatch
  
  Set objRegExp = New RegExp
  
  objRegExp.Pattern = strPattern
  objRegExp.IgnoreCase = blnIgnoreCase
  objRegExp.Global = False
  objRegExp.MultiLine = True
  
  Set colMatches = objRegExp.Execute(strString)
  
  For Each objMatch In colMatches
    If ((intBRef > 0) And (intBRef <= objMatch.SubMatches.Count)) Then
      RegExGetBRef = objMatch.SubMatches(intBRef - 1)
    End If
  Next
End Function

Open in new window

Comment
Watch Question

CERTIFIED EXPERT
Most Valuable Expert 2019
Most Valuable Expert 2018
Commented:
Machine accounts don't expire, so accordingly, there is no script to query for an expiration date.

Explore More ContentExplore courses, solutions, and other research materials related to this topic.