如何让用户密码在快过期时，发邮件提醒用户更改密码

大家都知道，在域环境中，组策略中可以设置当用户密码快过期时，电脑登录会有提示，但当用户出差，或是用OWA方式访问时，并不会收到相关提示，而导致道密码过期而无法收发邮件！

下面的方法，就是教大家，如何让用户密码在快过期时，发邮件提醒用户更改密码，让用户去OWA中去更改自已的密码，不至于发生密码过期，用户并不知道，而无法收发邮件！

以下是在AD、Exchange环境下，用邮件的方式通知用户密码到期提示的脚本，需要使用的，请将其路的Domainname.com和Domain改成你的域名，ADserver/Mailserver改为你的AD和Exchange的机器名，然后COPY下面的脚本存为.vbs格式，放在DC中，设置Scheduled Tasks，让其每天在固定时间执行！

注：此脚本文件会和组策略中的密码策略相对应！

此脚本为微软工程师专为某企业而写的，在些对其表示感谢！

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

'* Main Function: 從AD中比對每一個使用者的Password LastSet,如果距離過期日剩30,15,3,2,1的使用者,則發信通知

'*

'* Usage:

' For Example : cscript QuerryAD.vbs

'*

'* Copyright (C) 2004 Microsoft Corporation

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

'Option Explicit

'For FileSystemObject

Const ForReading = 1

Const ForAppending = 8

Const ForWriting = 2

Const ADS_PROPERTY_DELETE = 4

dim arrWillExpiredDays

'Please modify the variable

CONST MASTERMAIL = "administrator@domainname.com" '寄信人的Email Address

'const strSMTPServer = "mailserver" '寄信ExchangeServer

'const strSendUserName = "domainname\ACCOUNT" '有權限的使用者(寄信使用)

'const strSendPassword = "PASSWORD" '密碼

const strFullAdsiPath = "LDAP://DCserver.domainname.com/dc=domainname,dc=com" 'LDAP路徑

arrWillExpiredDays = Array(15,7,3,2,1) '將要過期天數的陣列

'Main Function

'Declare variables

Dim strTestMode

strTestMode = False 'use for debuging

'Cretae log file

Set WshSHell = CreateObject("Wscript.Shell")

Set objFSO = CreateObject("Scripting.FileSystemObject")

strFileName = Replace(Datevalue(Now), "-", "_")

strFileName = Replace(strFileName, "/", "_")

Public fLog

Set oLog = objFSO.OpenTextFile(strFileName & ".txt", ForWriting, TRUE)

PrintScreen Now

PrintScreen ""

sta = ListWillExpireUsers()

PrintScreen sta

PrintScreen ""

PrintScreen "The command runs successfully!"

PrintScreen Now

oLog.Close

'Program ending

wscript.quit

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

' Function Area

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

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

'*

'* Function: PrintScreen

'* Purpose: Show Message

'* Input: Message

'*

'* Output: None

'*

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

Sub PrintScreen(strMessage)

if strTestMode = True then

Wscript.Echo strMessage

end if

oLog.WriteLine strMessage

End Sub

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

'*Function ListWillExpireUsers(nDays)

'* List all user objects whose password will be expired or is expired

'* nDays: how many days the password will be expired

'*

'*

'*

'*-------------------------------------------------------------------

Function ListWillExpireUsers()

Dim strMailAddress

' Create User Object

Set objConnection = CreateObject("ADODB.Connection")

Set objCommand = CreateObject("ADODB.Command")

objConnection.Provider = "ADsDSOObject"

objConnection.Open "Active Directory Provider"

Set objCommand.ActiveConnection = objConnection

objCommand.CommandText = "<" & strFullAdsiPath & ">;(&(objectCategory=person)(objectclass=user));AdsPath,cn;subTree"

objCommand.Properties("Page Size") = 99 'specifies the maximum number of objects to return in a results set.

PrintScreen objCommand.CommandText

PrintScreen " "

Set objRecordSet = objCommand.Execute

If objRecordSet.RecordCount = 0 Then

PrintScreen "Error: Cannot found the user object in domain " & BaseDN & "."

Else

Dim intTotalAccount '計算找到幾位使用者

intTotalAccount = 0

objRecordSet.MoveFirst

Do Until objRecordSet.EOF

intTotalAccount = intTotalAccount +1

'Retrive user information

Dim oUser

Set oUser = GetObject(objRecordSet.Fields("ADsPath").Value)

For Each oUserProperty in oUser

PrintScreen oUserProperty.Name

Next

If (oUser.AccountDisabled = FALSE) Then

PrintScreen vbTab & "User Name : " & oUser.Name

sStatus = UserPwdExpire(oUser)

Select Case sStatus

Case 999999

PrintScreen vbTab & " The user " & oUser.samaccountname & " Password never expires."

Case Else

if sStatus >= 0 then

strMSG = "Your password is already expired in " & sStatus & " days!"

PrintScreen vbTab & " The user " & oUser.samAccountName & " password is expired after " & sStatus & " days!"

elseif sStatus < 0 then

strMSG = "Your mail account password will be expired in " & 0-sStatus & " days!" & vbcrlf & "Please change your password as soon as!"

PrintScreen vbTab & " The user " & oUser.samAccountName & " password will be expired in " & 0-sStatus & " days!"

end if

For each checkDays in arrWillExpiredDays

if checkDays = (0-sStatus) then

call fnCheck_SendMail(oUser,strMSG)

end if

next

End Select

else

PrintScreen vbTab & "User Name : " & oUser.Name

PrintScreen vbTab & " The user " & oUser.samaccountname & " Account Disabled."

end if

objRecordSet.MoveNext

PrintScreen " "

Loop

End If

PrintScreen "Total Accounts is " & intTotalAccount

ListWillExpireUsers = "OK"

End Function

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

'* Function UserPwdExpire(objUser, nMaxPwdAge)

'* Check if user object password is or will be expired

'* objUser: the user object

'*

'* nMaxPwdAge: maximum password age of domain

'*

'*-------------------------------------------------------------------

Function UserPwdExpire(objUser)

On Error Resume Next

Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000

Const SEC_IN_DAY = 86400

intCurrentValue = objUser.Get("userAccountControl")

If intCurrentValue and ADS_UF_DONT_EXPIRE_PASSWD Then

'The password does not expire.

UserPwdExpire = 999999 '永遠不過期

Else

dtmValue = objUser.PasswordLastChanged

if err.number <> 0 then

dtmValue = 0

err.Clear

end if

PrintScreen vbTab & " The password was last changed on " & DateValue(dtmValue) & " at " & TimeValue(dtmValue)

'PrintScreen vbTab & "The password was last changed on " & _

'DateValue(dtmValue) & " at " & TimeValue(dtmValue) & VbCrLf & _

' "The difference between when the password was last set" & VbCrLf & _

' "and today is " & int(now - dtmValue) & " days"

intTimeInterval = int(now - dtmValue)

Set objSysInfo = CreateObject("ADSystemInfo")

strDomain = objSysInfo.DomainShortName

Set objSysInfo = Nothing

Set objDomainNT = GetObject("WinNT://" & strDomain)

intMaxPwdAge = objDomainNT.Get("MaxPasswordAge")

If intMaxPwdAge < 0 Then

'WScript.Echo "The Maximum Password Age is set to 0 in the " & _

'"domain. Therefore, the password does not expire."

Else

intMaxPwdAge = (intMaxPwdAge/SEC_IN_DAY)

'Wscript.echo "The maximum password age is " & intMaxPwdAge & " days"

If intTimeInterval >= intMaxPwdAge Then

'PrintScreen vbTab & "The password has expired."

UserPwdExpire = int(intTimeInterval - intMaxPwdAge)

Else

'PrintScreen vbTab & "The password will expire on " & _

' DateValue(dtmValue + intMaxPwdAge) & " (" & _

' int((dtmValue + intMaxPwdAge) - now) & " days from today" & ")."

UserPwdExpire = int(now - (dtmValue + intMaxPwdAge))

End If

End If

End If

End Function

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

' Mail Message

'Reference : Creating and Sending a Message

'http://msdn.microsoft.com/library/en-us/cdosys/html/_cdosys_messaging_examples_creating_and_sending_a_message.asp?frame=true

'http://msdn.microsoft.com/library/en-us/cdosys/html/_cdosys_cdosendusing_enum.asp?frame=true

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

Sub SendMail(strFrom, strTo, strSubject, strBodyText)

Dim iMsg

Set iMsg = CreateObject("CDO.Message")

Dim iConf

Set iConf = CreateObject("CDO.Configuration")

Dim Flds

Set Flds = iConf.Fields

With Flds

' assume constants are defined within script file

.Item("cdoSendUsingMethod") = 2 ' cdoSendUsingPickup:1:Local , cdoSendUsingPort:2:Network

.Item("cdoSendUsingPort") = 25 'cdoSendUsingPort

.Item("cdoSMTPServer") = strSMTPServer

.Item("cdoSMTPConnectionTimeout") = 10 ' quick timeout

.Item("cdoSMTPAuthenticate") = cdoBasic

.Item("cdoSendUserName") = strSendUserName

.Item("cdoSendPassword") = strSendPassword

'.Item("cdoURLProxyServer") = "tpeproxy:80"

.Item("cdoURLProxyBypass") = "<local>"

.Item("cdoURLGetLatestVersion") = True

.Update

End With

With iMsg

Set .Configuration = iConf

.To = strTo

.From = strFrom

.Subject = strSubject

'.CreateMHTMLBody "This folder [" & strFolderPath & "] Created in " & intDayNum & " Days"

.TextBody = strBodyText

'.AddAttachment "C:\files\mybook.doc"

.Send

End With

End Sub

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

'*

'* Function: fnCheck_SendMail

'* Purpose: 檢查是否有符合寄信標準的使用者(以arrWillExpiredDays為準)

'* Input: objUser,MailMessage

'*

'* Output: None

'*

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

Function fnCheck_SendMail(objUser,strMSG)

'Send email

On Error Resume Next

Err.Clear

'某些User在此行發生Error

Dim PropArray

'PropArray = Array("proxyAddresses")

'oUser.GetInfoEx Array("proxyAddresses"), 0

aProxyAddress = objUser.GetEx("proxyAddresses")

If Err<>0 Then

PrintScreen vbTab & Time & " The user doesn't have email address."

Err.Clear

Else

For Each saProxyAddress in aProxyAddress

'Need a string variable to transfer the saProxyAddress

strMailAddress = saProxyAddress

ePos = Instr(1,strMailAddress,"SMTP:",VbTextCompare)

'PrintScreen vbTab & vbTab & "ePos = " & ePos

If ePos > 0 Then

strEmail = mid(strMailAddress,6)

PrintScreen vbTab & " Email Address: " & strEmail

'Use Exchange Server to send mail

'SendMail MASTERMAIL, strEmail, "Password expiration notification!", strMSG

'If server installed the SMTP Service

SendMessage MASTERMAIL, strEmail, "Password expiration notification!", strMSG

PrintScreen vbTab & " " & Time & " Finish sending email!"

Exit For

Else

'PrintScreen vbTab & vbTab & " No SMTP: string"

End If

Next

End If

end Function

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

' Send messages with CDO for Windows 2000

' strTo: [in] To

' strFrom: [in] From

' strSubject: [in] Subject

' strBodyFile: [in] Body text file

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

Sub SendMessage(strFrom, strTo, strSubject, strBodyText)

' For more information about CDO for Windows 2000, please refer to

' http://msdn.microsoft.com/library/en-us/exchanchor/htms/msexchsvr_cdowin2000.asp?frame=true

'On Error Resume Next

Dim oMessage ' as CDO.Message

Set oMessage = CreateObject("CDO.Message")

oMessage.TextBody = strBodyText

oMessage.To = strTo

oMessage.From = strFrom

oMessage.Subject = strSubject

Err.Clear

oMessage.Send

If Err.number <> 0 then

Wscript.Echo "Error in SendMessage: id=" & Err.number & ", source=" & Err.Source & ",Desc=" & Err.Description

Err.Clear

End If

Set oMessage = nothing

End Sub