' by Wang11
' May 29, 2013
Option Explicit
Const HOSTING_OU = "nimei"
Const SMTP_SERVER = "10.24.3.1"
Const STRFROM = ""
Const STRTO = ""
Const STRCC = ""
Const DAYS_FOR_EMAIL = 180
' 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 DO_DEBUG = True
Const DO_LOG = True
Dim objRoot
Dim numDays, iResult
Dim strDomainDN
Dim objContainer, objSub
Dim strOutput, strDisplayName, strAccountName
Set objRoot = GetObject ("LDAP://RootDSE")
strDomainDN = objRoot.Get ("defaultNamingContext")
Set objRoot = Nothing
numdays = GetMaximumPasswordAge (strDomainDN)
strOutput = "User" & vbTab & vbTab & vbTab & vbTab & "Account" & vbTab & _
"Expires In" & vbCrLf & "----------------------------------------------" & vbCrLf
If numDays > 0 Then
Set objContainer = GetObject ("LDAP://CN=Users," & strDomainDN)
Call ProcessFolder (objContainer, numDays)
Set objContainer = Nothing
If Len (HOSTING_OU) > 0 Then
Set objContainer = GetObject ("LDAP://OU=" & HOSTING_OU & "," & strDomainDN)
For each objSub in objContainer
Call ProcessFolder (objSub, numDays)
Next
Set objContainer = Nothing
End If
Call SendLog(strOutput)
End If
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 "The password for " & strName & " does not expire."
UserIsExpired = False
Else
iRes = 0
dtmValue = objUser.PasswordLastChanged
If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then
UserIsExpired = False
' dp "The password for " & strName & " has never been set."
Else
intTimeInterval = Int (Now - dtmValue)
' dp "The password for " & strName & " was last set on " & _
' DateValue(dtmValue) & " at " & TimeValue(dtmValue) & _
' " (" & intTimeInterval & " days ago)"
If intTimeInterval >= iMaxAge Then
' dp "The password for " & strName & " has expired."
UserIsExpired = False
'' No point in sending an email to an already expired user....
Else
iRes = Int ((dtmValue + iMaxAge) - Now)
' dp "The password for " & strName & " will expire on " & _
' DateValue(dtmValue + iMaxAge) & " (" & _
' iRes & " days from today)."
If iRes <= iDaysForEmail Then
' dp strName & " needs an email for password change"
UserIsExpired = True
Else
' dp strName & " does not need an email for password change"
UserIsExpired = False
End If
End If
End If
End If
End Function
Sub ProcessFolder (objContainer, iMaxPwdAge)
Dim objUser, iResult
objContainer.Filter = Array ("User")
For each objUser in objContainer
If Right (objUser.Name, 1) <> "$" Then
If IsEmpty (objUser.wwwHomePage) or IsNull (objUser.wwwHomePage) Then
' No mailbox."
ElseIf objUser.AccountDisabled = TRUE then
' Currently disabled."
Else
If UserIsExpired (objUser, iMaxPwdAge, DAYS_FOR_EMAIL, iResult) Then
if (len(objUser.DisplayName) < 20) Then
strDisplayName = objUser.DisplayName & Space(20 - len(objUser.DisplayName))
else
strDisplayName = objUser.DisplayName
end if
if (len(objUser.samAccountName) < 10) Then
strAccountName = objUser.samAccountName & Space(10 - len(objUser.samAccountName))
else
strAccountName = objUser.samAccountName
end if
strOutput = strOutput & strDisplayName & vbTab & strAccountName & vbTab & iResult & " days" & vbCrLf
Call SendEmail (objUser, iResult)
End If
End If
End If
Next
End Sub
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.wwwHomePage
objMail.AddAttachment "d:\域账户密码修改教程.pdf"
objMail.Subject = "您的域帐户密码即将过期 " & iResult & " Days "
objMail.htmlbody = "Hi "& objUser.sn & "" & vbCRLF & vbCRLF & _
"
我们检测到您的域帐户 (" & objUser.sAMAccountName & _
") 的密码即将在 " & iResult & " 天后过期"& vbCRLF & _
"请第一时间使用登陆
http://game-password.vbCRLF & vbCRLF & _
"
修改密码,关于如何修改密码详见附件教程 ,如有其他问题, 请发邮件至it@game.com或拨打分机获得支持.
" & vbCRLF & vbCRLF & _
"" & vbCRLF & _
"
IT部
"
objMail.Send
Set objMail = Nothing
End Sub
Sub SendLog(strTextBody)
Dim WSHShell
set WSHShell = CreateObject("WScript.Shell")
strTextBody = strTextBody & vbCrLf & vbCrLf & _
WScript.ScriptFullName & " running on " & WSHShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
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 = STRTO
objMail.CC = STRCC
objMail.Subject = "[LOG] Password Expirations"
objMail.Textbody = strTextBody
objMail.Send
Set objMail = Nothing
End Sub