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

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

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

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

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

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

'********************************************************************
'* Main Function: ��AD中比�γ恳��使用者的Password LastSet,如果距�x�^期日剩30,15,3,2,1的使用者,�t�l信通知
'*
'* 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 = "[email protected]"          '寄信人的Email Address
'const strSMTPServer = "mailserver"              '寄信ExchangeServer 
'const strSendUserName = "domainname\ACCOUNT"         '有�嘞薜氖褂谜�(寄信使用)
'const strSendPassword  = "PASSWORD"             '密�a
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 '永�h不�^期
 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:  �z查是否有符合寄信��实氖褂谜�(以arrWillExpiredDays���)
'* Input:    objUser,MailMessage
'*          
'* Output:   None
'*
'********************************************************************
Function fnCheck_SendMail(objUser,strMSG)

 'Send email
 On Error Resume Next
 Err.Clear
  
 '某些User在此行�l生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