转载的文章，觉得非常的实用，但是经过测试发现能够统计数据，不能够自动发送邮件，所以自己修改了一下，测试后正常发送邮件；
3月13修改，增加抄送邮件地址
大家都知道，在域环境中，组策略中可以设置当用户密码快过期时，电脑登录会有提示，但当用户出差，或是用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 = "sysadmin@domainname.com" ‘需要修改发送邮件的地址
'const strSMTPServer = "mailserver"
'const strSendUserName = "domainname\sysadmin"
'const strSendPassword = "Password"
const strFullAdsiPath = ”LDAP://ADserver.domain.local/dc=domain,dc=com“ ‘需要修改域控服务器的地址。
arrWillExpiredDays = Array(30,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 possible!" ‘邮件内容
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") = "mail.pcainv.com"
'.Item("cdoSMTPConnectionTimeout") = 10 ' quick timeout
'.Item("cdoSMTPAuthenticate") = cdoBasic
'.Item("cdoSendUserName") = "pca\yfu"
'.Item("cdoSendPassword") = "1234!Qaz"
'.Item("cdoURLProxyServer") = "tpeproxy:80"
'.Item("cdoURLProxyBypass") = "<local>"
'.Item("cdoURLGetLatestVersion") = True
'.Update
NameSpace = "http://schemas.microsoft.com/cdo/configuration/"
.Item(NameSpace&"sendusing") = 2
.Item(NameSpace&"smtpserver") = "mailserver" ’SMTP服务器地址
.Item(NameSpace&"smtpserverport") = 25 ‘SMTP服务器端口
.Item(NameSpace&"smtpauthenticate") = 1
.Item(NameSpace&"sendusername") = "Domainname\sysadmin" ’发信人用户名
.Item(NameSpace&"sendpassword") = "Password" ‘发信人密码
.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"
.CC = "sysadmin@domainname.com" '抄送邮件地址，可以选择管理员邮箱
.Send
End With
End Sub
'********************************************************************
'*
'* Function: fnCheck_SendMail
'* Purpose:
'* Input: objUser,MailMessage
'*
'* Output: None
'*
'********************************************************************
Function fnCheck_SendMail(objUser,strMSG)
'Send email
On Error Resume Next
Err.Clear
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
