Const ADS_UF_PASSWD_CANT_CHANGE = &H40
Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
Const ADS_UF_ACCOUNTDISABLE = &H02
Dim strFilePath, objFSO, objFile, adoConnection, adoCommand
Dim objRootDSE, strDNSDomain, strFilter, strQuery, adoRecordset
Dim strDN, objShell, lngBiasKey, lngBias, blnPwdExpire,blnAccountDisabled
Dim objDate, dtmPwdLastSet, lngFlag, k, oDomain, maxPwdAge, numDays,whenPasswordExpires, strEmailMessage
'====================================
'Script to change a filename using timestamps
Dim strMonth, strDay
strMonth = DatePart("m", Now())
strDay = DatePart("d",Now())
if Len(strMonth)=1 then
strMonth = "0" & strMonth
else
strMonth = strMonth
end if
if Len(strDay)=1 then
strDay = "0" & strDay
else
strDay = strDay
end if
'===================================
strFilePath = "D:\users_DOMAIN_" & DatePart("yyyy",Now()) & strMonth & strDay & ".txt"
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
' Determine the DNS domain from the RootDSE object.
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("DefaultNamingContext")
' Filter to retrieve all user objects.
strFilter = "(&(objectCategory=person)(objectClass=user))"
' Filter to retrieve all computer objects.
' strFilter = "(objectCategory=computer)"
strQuery = "
& ";displayName,pwdLastSet,userAccountControl,mail;subtree"
adoCommand.CommandText = strQuery
adoCommand.Properties("Page Size") = 100
adoCommand.Properties("Timeout") = 30
adoCommand.Properties("Cache Results") = False
' Iterate thru the users collection in Active Directory
objFile.WriteLine "DISPLAY NAME , PASSWORD EXPIRES, ACCOUNT DISABLED, PASSWORD LAST SET , EMAIL, PASSWORD EXPIRES, NUMBER OF DAYS"
Set oDomain = GetObject("LDAP://dc=DOMAIN,dc=local")
Set maxPwdAge = oDomain.Get("maxPwdAge")
numDays = ((maxPwdAge.HighPart * 2 ^ 32) + maxPwdAge.LowPart) / -864000000000
Set adoRecordset = adoCommand.Execute
Do Until adoRecordset.EOF
Set objDate = adoRecordset.Fields("pwdLastSet").Value
lngFlag = adoRecordset.Fields("userAccountControl").Value
blnPwdExpire = True
dtmPwdLastSet = Integer8Date(objDate, lngBias)
whenPasswordExpires = DateAdd("d", numDays, dtmPwdLastSet)
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
If (lngFlag And ADS_UF_ACCOUNTDISABLE) <> 0 Then
blnAccountDisabled=True
Else
blnAccountDisabled=False
If IsNull(adoRecordset.Fields("mail").Value) or IsEmpty(adoRecordset.Fields("mail").Value) Then
Else
'check if password expires
If blnPwdExpire = True Then
If DateDiff("d", Now, whenPasswordExpires) <=14 AND DateDiff("d", Now, whenPasswordExpires) >=0 Then
strEmailMessage="1" 'password will expire in less than 14 days
objFile.WriteLine adoRecordset.Fields("displayName").Value & "," & blnPwdExpire & " , " & blnAccountDisabled & " , " & dtmPwdLastSet & " , " & adoRecordset.Fields("mail").Value & "," & whenPasswordExpires & "," & DateDiff("d", Now, whenPasswordExpires)
Call sendEmail(adoRecordset.Fields("mail").Value,FormatDateTime(whenPasswordExpires,2),strEmailMessage)
ElseIf DateDiff("d", Now, whenPasswordExpires) <0 Then
strEmailMessage="0" 'password has already expired
objFile.WriteLine adoRecordset.Fields("displayName").Value & "," & blnPwdExpire & " , " & blnAccountDisabled & " , " & dtmPwdLastSet & " , " & adoRecordset.Fields("mail").Value & "," & whenPasswordExpires & "," & DateDiff("d", Now, whenPasswordExpires)
Call sendEmail(adoRecordset.Fields("mail").Value,FormatDateTime(whenPasswordExpires,2),strEmailMessage)
End If
End If
End if
End If
adoRecordset.MoveNext
Loop
adoRecordset.Close
' Clean up.
objFile.Close
adoConnection.Close
Set objFile = Nothing
Set objFSO = Nothing
Set objShell = Nothing
Set adoConnection = Nothing
Set adoCommand = Nothing
Set objRootDSE = Nothing
Set adoRecordset = Nothing
Wscript.Echo "Done"
'=============================
'Function -Integer8 attribute function courtesy of Richard Mueller - http://www.rlmueller.net/Integer8Attributes.htm
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
'=============================
'Send Email function
Sub sendEmail(strEmail, expirationDate, msgFlag)
'Accept input parameters
Dim email
Dim expirationDate
Dim strMessage
email= strEmail
expirationDate= expirationDate
strMessage= msgFlag
If strMessage=1 then
strMessage=" will expire on "
strMessage2= "Password Expiration"
ElseIf strMessage=0 then
strMessage=" has already expired last "
strMessage2= "Expired Password"
End If
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = "Message Alert from Domain Administrator: " & strMessage2
objMessage.From = "admin@domain.local"
objMessage.To = email
objMessage.TextBody = "Your domain password " & strMessage & " " & FormatDateTime(expirationDate,1) & ". This password notification notice is being sent once a week " & vbCrLF & vbCrLf & "Please change your password. "& vbCrlf & vbCrlf & vbCrlf & vbCrlf & "Domain Administrator"
'==This section provides the configuration information for the remote SMTP server.
'==Normally you will only change the server name or IP.
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.domain.local"
'Server port number(typically 25)
objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
objMessage.Configuration.Fields.Update
objMessage.Send
Set objMessage = Nothing
End Sub
The use of ADO was actually not my preference since it requires you to use an additional layer just to connect to ADSI. My original script was actually using the WinNT provider to access Active Directory. But upon further research, I found out that the WinNT provider does not have pointers to access the email attribute in the user object. I need this attribute to send emails to those users whose passwords will be expiring. This prompted me to re-write my script to use the LDAP provider and ADO.
I have used the following as reference to write this script. Feel free to use it and customize in a way that suites your requirement.
http://www.rlmueller.net/
http://support.microsoft.com/kb/323750
http://msdn2.microsoft.com/en-us/library/aa772170.aspx
