How to generate and export soon-to-expire password users report

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 strItem, strPrefix, objFSO, objLogFile


Const ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objLogFile = objFSO.CreateTextFile("C:\Scripts\PasswordExp.csv", ForWriting, True)


objLogFile.Write "sAMAccountName,"
objLogFile.Write "mail,"
objLogFile.Write "passwordExpiresAt"
objLogFile.Writeline


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


' 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


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"


' 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 = "sAMAccountName,mail,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
strName = adoRecordset.Fields("sAMAccountName").Value
strEmail = adoRecordset.Fields("mail").Value & ""
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)


objLogFile.Write strName & ","
objLogFile.Write strEmail & ","
objLogFile.Write dtmExpires
objLogFile.Writeline
adoRecordset.MoveNext
Loop


' Clean up.
objLogFile.Close
adoRecordset.Close
adoConnection.Close


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