' 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
