邮件提醒AD域用户更改密码

假如域用户密码即将过期，可以用邮件提醒用户更改密码么？AD能实现么。 实际上，AD暂时来说没有这个功能，不过在TechNet上有vb script 模板实现此功能，在Exchange 2010配合Active Directory 2008 的环境下实现的。

可以参考下

<a href="http://gallery.technet.microsoft.com/scriptcenter/f7f5f7ed-14ee-4d0e-81c2-7d95ce7e08f5">http://gallery.technet.microsoft.com/scriptcenter/f7f5f7ed-14ee-4d0e-81c2-7d95ce7e08f5</a>

脚本

'==========================================================================  

'Milan on 1/12/2011  

' This script can be used to notify users of when their windows passords  

' are going to expire. Especially useful in those cases where user does not logon  

' to windows with individual login and uses OWA for email  

' Script is currently running fine in a Exchange 2010 env with AD 2008  

On Error Resume Next 

Const ADS_SCOPE_SUBTREE = 2  

Const SEC_IN_DAY = 86400  

Const ADS_UF_DONT_EXPIRE_PASSWD = &amp;h10000 ' tocheck for accounts that have "no expire" set on the password  

Dim maxPwdAge  

maxpwdage = 90 'set this according to policy in your organization  

Dim numDays  

Dim warningDays  

warningDays = 14 ' set this according to policy in your organization  

'ADO to access Active Directory  

Set objConnection = CreateObject("ADODB.Connection")  

Set objCommand = CreateObject("ADODB.Command")  

objConnection.Provider = "ADsDSOObject" 

objConnection.Open "Active Directory Provider" 

Set objCommand.ActiveConnection = objConnection  

Set objRootDSE = GetObject("LDAP://rootDSE")  

DomainString = objRootDSE.Get("dnsHostName")  

objCommand.Properties("Page Size") = 1000  

objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE  

objCommand.CommandText = "SELECT DisplayName,mail,DistinguishedName,sAMAccountName  FROM 'LDAP://OU=regions, DC=vsc, DC=com'" &amp; _  

    " where objectClass='user'" 

    '" WHERE objectCategory='user'" 'This was creating problems where it was picking up two objects that were contacts, not users  

Set objRecordSet = objCommand.Execute  

objRecordSet.MoveFirst 'get to the first record in the recordset  

Do Until objRecordSet.EOF  

    strUser = objRecordSet.Fields("sAMAccountName").Value  

    strDN = objRecordSet.Fields("DistinguishedName").Value   'This is important otherwise we cannot pull the "last Password Change date  

    strMail = objRecordSet.Fields("mail").Value  

    strFullName = objRecordSet.Fields("DisplayName").Value  

        For Each objItem in strUser  'one record at a time  

            Set objUserLDAP = GetObject ("LDAP://" &amp; strDN &amp; "")  

            intCurrentValue = objUserLDAP.Get("userAccountControl") ' For checking if the account is disabled  

            '*******************************************************************************************  

            'BEGIN OF PASSWORD EXPIRATION WARNING  

                numDays = maxpwdage  

                dtVal = objUserLDAP.PasswordLastChanged 'The latest date the user changed her/his password  

                whenPasswordExpires = DateAdd("d", numDays, dtval)  

                fromDate = Date 

                daysLeft = DateDiff("d",fromDate,whenPasswordExpires)  

                If (daysLeft &lt; warningDays) and (daysLeft &gt; 0) then  'If 14 days or less remain until Password expires  

                    If strMail &lt;&gt; "" Then 

                        Set objEmail = CreateObject("CDO.Message")  

                        objEmail.From = "admin@watchdog" 

                        objEmail.To = strmail  

                        objemail.cc = "[email protected]" 

                        objEmail.Subject = strFullname &amp; ", your Windows Password is expiring soon!!"   

                        objEmail.HTMLBody = "Your Password Expires in " &amp; daysLeft &amp; " day(s)" &amp; vbcrlf &amp; _  

                        "&lt;h3&gt;Windows users - Press CTRL-ALT-DEL and select the CHANGE A PASSWORD option&lt;/h3&gt;" &amp; vbcrlf &amp; _  

                        "&lt;h3&gt;Outlook Web Users - Please click (Options) and choose (Change your Password)&lt;/h3&gt;" &amp; vbcrlf &amp; _  

                        "&lt;h3&gt;This reminder will continue until you change your password&lt;/h3&gt;" &amp; vbcrlf &amp; _  

                        "&lt;h3&gt; Please do not reply to this email&lt;/h3&gt;" 

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

                        objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "192.168.xx.xx" 

                        objEmail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25  

                        objEmail.Configuration.Fields.Update  

                        objEmail.Send  

                      'end if  

                    End If 

                End if  

        Next 

    objRecordSet.MoveNext ' Keep going down the table  

Loop 

Set objConnection = Nothing 

Set objCommand = Nothing 

Set objCommand.ActiveConnection = Nothing 

Set objRootDSE = Nothing 

Set objRecordSet = Nothing 

Set objUserLDAP = Nothing 

Set objEmail = Nothing 

WScript.Quit  

本文转自 VirtualTom 51CTO博客，原文链接：http://blog.51cto.com/virtualtom/1142806，如需转载请自行联系原作者