'  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