AD 檢查密碼到期自動自信

' exch-pwd-expires.vbs
'
' Alan.Zhou
' Jun 26, 2007
'Email: alan.zhou@hi-p.com
'
' This program scans all users in the AD,for users whose passwords have either
' already expired or will expire within DAYS_FOR_EMAIL days.
'
' An email is sent, using CDO, via the SMTP server specified as SMTP_SERVER to the
' user to tell them to change their password. You should change strFrom to match
' the email address of the administrator responsible for password changes.
'
' You will, at a minimum, need to change the SMTP_SERVER,  and the STRFROM constants.
' If you run this on an Exchange server, then SMTP_SERVER can
' be "127.0.0.1" - and it may be either an ip address or a resolvable name.
'

 'Option Explicit

 ' Per environment constants - you should change these!
 Const SMTP_SERVER  = " "
 Const STRFROM   = " "
 Const DAYS_FOR_EMAIL  = 7

 '以此程式內容來說，是定義為7天之內的都會寄送郵件。天數是在下列地方修改：Const DAYS_FOR_EMAIL  = 7

 ' System Constants - do not change
 Const ONE_HUNDRED_NANOSECOND    = .000000100   ' .000000100 is equal to 10^-7
 Const SECONDS_IN_DAY            = 86400
 Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
 Const E_ADS_PROPERTY_NOT_FOUND  = &h8000500D

 ' Change to "True" for extensive debugging output
 Const bDebug   = True
 Const ForWriting = 2
 Const ForReading = 1
 Const ForAppending = 8
 Const TristateUseDefault    = -2

' 簡單註記 by Japlin on 2010.12.22
'========================================================
' 使用者帳號      ： Mid (objUser.Name, 4)
' 使用者郵件帳號  ： objUser.userPrincipalName
'  {  UPN=系統主體用戶，是系統用戶以完整的電子郵件格式書寫的名稱 }
'  {  如：name@domain.com, Email.Name@emailAddress.com }
' 使用者登入名稱  ： objUser.sAMAccountName  
'   {  sAMAccountName = Domain account login name }
' Mailbox         ： objUser.Mail
' 密碼最後變更日期： dtmValue = objUser.PasswordLastChanged
' 密碼保存最長期間： numdays = GetMaximumPasswordAge (strDomainDN)
'   {  在 UserIsExpired Function 內，變數名稱＝iMaxAge }
' 密碼變更在幾天前： intTimeInterval = Int (Now - dtmValue)  
'   {  今天日期-密碼最後變更日期 }
' 密碼是否過期    ： if intTimeInterval >= iMaxAge
' 密碼在幾天後到期： iRes = Int ((dtmValue + iMaxAge) - Now)
'   {  密碼最後變更日期 + 密碼保存最長期間 - 今天日期 }
' 發送郵件通知條件： If iRes <=  DAYS_FOR_EMAIL    
'   {  DAYS_FOR_EMAIL 是在程式內自定義，並非AD上所定義的通知日期 }
'========================================================

 Dim objRoot , objFSO
 Dim numDays, iResult
 Dim strDomainDN , Outputfile
 Dim objContainer, objSub

 Set objFSO = CreateObject("Scripting.FileSystemObject")
 Outputfile = "./exch-pwd-expires-2-log.txt"
 CreateOutputFile OutputFile
 wscript.sleep 1000

 Set objRoot = GetObject ("LDAP://rootDSE")
 strDomainDN = objRoot.Get ("defaultNamingContext")
 Set objRoot = Nothing

 numdays = GetMaximumPasswordAge (strDomainDN)
 dp strDomainDN & " 密碼保存最長期間: " & numDays & vbCRLF

 If numDays > 0 Then
    Set objConnection = CreateObject("ADODB.Connection")
 Set objCommand =   CreateObject("ADODB.Command")
 objConnection.Provider = "ADsDSOObject"
 objConnection.Open "Active Directory Provider"
 Set objCommand.ActiveConnection = objConnection

 objCommand.Properties("Page Size") = 1000
 objCommand.Properties("Searchscope") = 2
 'objCommand.CommandText = _
 '    "SELECT AdsPath, whenCreated FROM 'LDAP://"& strDomainDN &"' WHERE objectCategory='user'"
 objCommand.CommandText = _
         "Select AdsPath, whenCreated from 'LDAP://" & strDomainDN & _
             "' where objectClass ='user' and objectClass <>'computer'"
 Set objRecordSet = objCommand.Execute
 objRecordSet.MoveFirst
 Do Until objRecordSet.EOF
  Set objUser = GetObject(objRecordSet.Fields("AdsPath").Value)
  If Right (objUser.Name, 1) <> "$" Then
   If IsEmpty (objUser.Mail) or IsNull  (objUser.Mail) Then
    dp Mid (objUser.Name, 4) & " 沒有 Mailbox" & vbCRLF
            Else
                If UserIsExpired (objUser, numdays, DAYS_FOR_EMAIL, iResult) Then
     dp "---已經發送 Email 給 " & objUser.Mail & vbCRLF
     Call SendEmail (objUser, iResult)
    Else
     dp "...不需要發送 Email" & vbCRLF
    End If
   End If
  End If
     objRecordSet.MoveNext
 Loop

 End If

 WScript.Echo "Done"

Function GetMaximumPasswordAge (ByVal strDomainDN)
 Dim objDomain, objMaxPwdAge
 Dim dblMaxPwdNano, dblMaxPwdSecs, dblMaxPwdDays

 Set objDomain = GetObject("LDAP://" & strDomainDN)
 Set objMaxPWdAge = objDomain.maxPwdAge

 If objMaxPwdAge.LowPart = 0 And objMaxPwdAge.Highpart = 0 Then
  ' Maximum password age is set to 0 in the domain
  ' Therefore, passwords do not expire
  GetMaximumPasswordAge = 0
 Else
  dblMaxPwdNano = Abs (objMaxPwdAge.HighPart * 2^32 + objMaxPwdAge.LowPart)
  dblMaxPwdSecs = dblMaxPwdNano * ONE_HUNDRED_NANOSECOND
  dblMaxPwdDays = Int (dblMaxPwdSecs / SECONDS_IN_DAY)
  GetMaximumPasswordAge = dblMaxPwdDays
 End If
End Function

Function UserIsExpired (objUser, iMaxAge, iDaysForEmail, iRes)
 Dim intUserAccountControl, dtmValue, intTimeInterval
 Dim strName

 On Error Resume Next
 Err.Clear

 strName = Mid (objUser.Name, 4)
 intUserAccountControl = objUser.Get ("userAccountControl")

 If intUserAccountControl And ADS_UF_DONT_EXPIRE_PASSWD Then
  dp strName & " 的密碼尚未過期."
  UserIsExpired = False
 Else
  iRes = 0
  dtmValue = objUser.PasswordLastChanged
  If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then
   UserIsExpired = True
   dp strName & " 的密碼尚未設定." & vbCRLF
  Else
   intTimeInterval = Int (Now - dtmValue)
   dp strName & " 的密碼最後設定日期：" & _
    DateValue(dtmValue) & " 在 " & TimeValue(dtmValue) & _
    " (" & intTimeInterval & " 天以前) 最大日期：" & iMaxAge

   If intTimeInterval >= iMaxAge Then
    dp strName & " 的密碼已經過期."
    UserIsExpired = True
   Else
    iRes = Int ((dtmValue + iMaxAge) - Now)
    dp strName & " 的密碼將於 " & _
     DateValue(dtmValue + iMaxAge) & " (" & _
     iRes & " 天後到期)."

    If iRes <= iDaysForEmail Then
     'dp strName & " 需要一個 email 帳號作為密碼更改通知"
     UserIsExpired = True
    Else
     'dp strName & " 不需要 email 帳號作為密碼更改通知"
     UserIsExpired = False
    End If
   End If

  End If
 End If
End Function

Sub SendEmail (objUser, iResult)
 Dim objMail

 Set objMail = CreateObject ("CDO.Message")

 objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusing")      = 2
 objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserver")     = SMTP_SERVER
 objMail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
 objMail.Configuration.Fields.Update

 objMail.From     = STRFROM
 objMail.To       = objUser.Mail

 objMail.Subject  = "密碼到期通知：" & Mid (objUser.Name, 4)
 objMail.Textbody = "Dear " & objUser.givenName & ":" & vbCRLF & _
    "您的網域和郵件帳號 (" & objUser.sAMAccountName & ")" & vbCRLF & _
    "密碼將於 " & iResult & " 天後到期了。 " & vbCRLF & _
    "請您儘快更換您的密碼." & vbCRLF & vbCRLF & _
    "謝謝！" & vbCRLF & _
    "XXX 資訊中心 敬上"

 objMail.Send
'userPrincipalName
 Set objMail = Nothing
End Sub

Sub dp (str)
 If bDebug Then
  WriteOutputToFile str
 End If
End Sub


'---------------------------------------------------------------------------------------
'Function: CreateOutputFile
'Last Modified: 10/11/05 .csm
'This function writes the output file for the script.  The name and destination of the
'file is passed in as string variable. Uses Wscript.network to find current user id
'and domain, tries Win32_ComputerSystem and prompts if both of these methods fail.
'---------------------------------------------------------------------------------------
Function CreateOutputFile(OutputFile)
Dim tmpCurrentUser, objNetwork
strComputer = "."
'get local user information and add to the header file
Set objNetwork = CreateObject("Wscript.Network")
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_ComputerSystem")
For Each objItem In colItems
 tmpCurrentUser = objItem.UserName
Next

If IsNull(tmpCurrentUser) Then
    ScriptDomain = objNetwork.UserDomain
 ScriptUser = objNetwork.UserName
 If ISNull(ScriptDomain) or IsNull(ScriptUser) Then ' have user manually enter information as a last resort
  ScriptDomain = InputBox("請輸入 Domain:")
  ScriptUser = InputBox("請輸入 User ID:")
 End if
Else
 tmpCurrentUser = Split(tmpCurrentUser,"\")
 ScriptDomain = tmpCurrentUser(0)
 ScriptUser = tmpCurrentUser(1)
End if

Set objFile = objFSO.CreateTextFile(Outputfile) 'Create the File
objFile.Close
'Re-open file, write the headcer & 1st line of output
Set objFile = objFSO.OpenTextFile(Outputfile, ForWriting, true, TristateUseDefault)
objFile.WriteLine "Check domain password log"
objFile.WriteLine "Created: " & Now
objFile.WriteLine "Computer Domain: " & ScriptDomain
objFile.WriteLine "Current User: " & ScriptUser & vbcrlf
objFile.Close
End Function


'---------------------------------------------------------------------------------------
'Function: WriteOutputToFile
'Last Modified: 9/28/05 .csm
'This function accepts a string and writes it to the output file
'---------------------------------------------------------------------------------------
Function WriteOutputToFile(strOutput)
'Check if file exists & write the data
On Error Resume Next
'Wscript.echo (strOutput)

If objFSO.FileExists(Outputfile) Then
 Set objFile = objFSO.OpenTextFile(Outputfile, ForAppending)
 objFile.Write strOutput
 objFile.WriteBlankLines(1)
 objExplorer.Document.Body.InnerHTML = "Script progress: <br>" & strOutput
Else
 ' file not found
 'Wscript.echo "Error file not found.  Please run the script again."
End If
objFile.Close
End Function