Баян конечно страшный и способов реализации гораздо больше чем «много», но а тут моя компиляция-модификация 🙂

Копирайты и ссылки оставляю, так что всё честно.

Работает элементарно просто: из AD отбираются учётные записи пользователей со сроком окончания действия пароля 1, 3, 5 и 7 дней, после чего им отсылаются письма с напоминанием о необходимости сменить пароль.


Письма с уведомлениями выглядят примерно так:

' PwdExpires.vbs
' VBScript program to find all user accounts where the password
' is about to expire in a specified number of days.
'
' ----------------------------------------------------------------------
' Copyright (c) 2009-2011 Richard L. Mueller
' Hilltop Lab web site - http://www.rlmueller.net
' Version 1.0 - September 19, 2009
' Version 1.1 - December 29, 2009 - Handle Null pwdLastSet.
' Version 1.2 - April 6, 2011 - Correct email address.
'
' This program assumes there is one password policy for the domain. The
' program finds all users whose password will expire in the specified
' period. The program emails a message to each user found. The program
' uses the email address in the "mail" attribute, if it has a value.
' This corresponds to the "E-mail" field on the "General" tab of ADUC.
' Otherwise, the program uses the "primary" email address in the
' "proxyAddresses" attribute of the user.
'
' You have a royalty-free right to use, modify, reproduce, and
' distribute this script file in any way you find useful, provided that
' you agree that the copyright owner above has no warranty, obligations,
' or liability for such use.
 
Option Explicit
 
Dim adoCommand, adoConnection, strBase, strFilter, strAttributes
Dim objRootDSE, strDNSDomain, strQuery, adoRecordset
Dim dtmDate1, dtmDate2, intDays, strName, strEmail, dtmDaysLeft
Dim lngSeconds1, str64Bit1, lngSeconds2, str64Bit2
Dim objShell, lngBiasKey, lngBias, k
Dim objDomain, objMaxPwdAge, lngHighAge, lngLowAge, sngMaxPwdAge
Dim objDate, dtmPwdLastSet, dtmExpires
Dim arrEmails, strItem, strPrefix
 
' Specify number of days. Any users whose password expires within
' this many days after today will be processed.
intDays = 7
 
' 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"
 
' 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,proxyAddresses,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
    strEmail = adoRecordset.Fields("mail").Value & ""
    arrEmails = adoRecordset.Fields("proxyAddresses").Value
    If (strEmail = "") And (IsNull(arrEmails) = False) Then
        ' Select primary email address.
        For Each strItem In arrEmails
            strPrefix = Left(strItem, 5)
            If (strPrefix = "SMTP:") Or (strPrefix = "X400:") Then
                strEmail = Mid(strItem, 6)
                Exit For
            End If
        Next
    End If
    ' 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)
	dtmDaysLeft = DateDiff("d",FormatDateTime(Date,2),FormatDateTime(dtmExpires,2))
'wscript.echo strName,dtmExpires,dtmDaysLeft
	IF ((dtmDaysLeft = 7) OR (dtmDaysLeft = 5) OR (dtmDaysLeft = 3) OR (dtmDaysLeft = 1)) Then
    If (strEmail <> "") Then
'wscript.echo strName,dtmExpires,dtmDaysLeft	
        ' Send an email message to the user.
        Call SendEmailMessage(strEmail, objDomain.Get("name") & "\" & strName, dtmExpires, dtmDaysLeft)
'        Wscript.Echo "Message for " & strName & " sent to " & strEmail
    Else
'        Wscript.Echo "No email address for " & strName
    End If
	End If
    ' Move to the next record in the recordset.
    adoRecordset.MoveNext
Loop
 
' Clean up.
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
 
Sub SendEmailMessage(ByVal strDestEmail, ByVal strNTName, ByVal dtmDate, ByVal dtmDaysLeft)
	' Send by connecting to port 25 of the SMTP server.
	Const cdoSendUsingPort = 2
 
dim iMsg, iConf,Flds,shtml 
 
	set iMsg = CreateObject("CDO.Message")
	set iConf = CreateObject("CDO.Configuration")
 
	Set Flds = iConf.Fields
 
	' Set the CDOSYS configuration fields to use port 25 on the SMTP server
	With Flds
	    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = cdoSendUsingPort
	    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "SMTP.DOMAIN.RU" 
	    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 10
	    .Update
	End With
 
	' Build HTML for message body.
if dtmDaysLeft = 1 then
	shtml ="<HTML>"
	shtml = shtml & "<H1><B><FONT face='Arial Rounded MT Bold' color=#FF0000 size=4>Последнее предупреждение об истечении срока действия пароля</FONT></B></H1>"
	shtml = shtml & "<P><FONT face=Arial size=2>Вы получили это письмо, потому что срок действия Вашего пароля для учётной записи " & strNTName & " истекает " & dtmDate & " (т.е. завтра!).<br>"
	shtml = shtml & "Если пароль не будет сменён до указанного срока, доступ ко всем системам будет автоматически закрыт!<br><br>В случае блокировки Вашей учётной записи необходимо:<br>* Для Москвы - обратиться в техподдержку по телефону XXXX<br>* Региональным пользователям необходимо обратиться в свою службу технической поддержки</FONT></P>"
	shtml = shtml & "</BODY></HTML>"
else
	shtml ="<HTML>"
	shtml = shtml & "<H1><B><FONT face='Arial Rounded MT Bold' color=#e20074 size=4>Уведомление об истечении срока действия пароля</FONT></B></H1>"
	shtml = shtml & "<P><FONT face=Arial size=2>Вы получили это письмо, потому что срок действия Вашего пароля для учётной записи " & strNTName & " истекает " & dtmDate & ".<br>"
	shtml = shtml & "Для предотвращения отказа в доступе, необходимо поменять пароль до окончания этого срока.</FONT></P>"
	shtml = shtml & "</BODY></HTML>"
end if	
 
	' Apply the settings to the message.
	With iMsg
	    Set .Configuration = iConf
	    .To = strDestEmail
	    .Bcc = "admin@domain.ru"
	    .From = "info@domain.ru"
		Select Case dtmDaysLeft
			Case 7
				.Subject = "Пароль для учётной записи " & strNTName & " истечёт " & dtmDate & " (через " & dtmDaysLeft & " дней)."
			Case 5
				.Subject = "Пароль для учётной записи " & strNTName & " истечёт " & dtmDate & " (через " & dtmDaysLeft & " дней)."
			Case 3
				.Subject = "Пароль для учётной записи " & strNTName & " истечёт " & dtmDate & " (через " & dtmDaysLeft & " дня)."
			Case 1
				.Subject = "Пароль для учётной записи " & strNTName & " истечёт " & dtmDate & " (через " & dtmDaysLeft & " день)."
 
				.Fields("urn:schemas:httpmail:Importance").Value = 2
				.Fields("urn:schemas:mailheader:importance").Value = "High"
 
				.Fields("urn:schemas:httpmail:priority").Value = 1
				.Fields("urn:schemas:mailheader:priority").Value = 1
 
				.Fields("urn:schemas:mailheader:X-MSMail-Priority").Value = "High"
				.Fields("urn:schemas:mailheader:X-Priority").Value = 1
 
				.Fields("urn:schemas:httpmail:X-MSMail-Priority").Value = "High"
				.Fields("urn:schemas:httpmail:X-Priority").Value = 1
				.Fields.update
		End Select
	    .HTMLBody = shtml		
	    .Send
	End With
 
 
	' Clean up variables.
	Set iMsg = Nothing
	Set iConf = Nothing
	Set Flds = Nothing
 
End Sub

Скачать скрипт PwdExpiresAllUsers.zip