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

      大家都知道，在域环境中，组策略中可以设置当用户密码快过期时，电脑登录会有提示，但当用户出差，或是用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