源代码：

On Error Resume Next

Const LDAPAD = "LDAP://DC=xxxx,DC=com" Const alertDays = 7 Const path = "d:\alluser.txt" Const mailFrom = "" Const smtpserver = "x.x.x.x" Const sendusername = "xxxx" sendpassword = "xxxx" Const smtpserverport = 25 Set fso=CreateObject("Scripting.FileSystemObject") set file=fso.CreateTextFile("d:\快过期users.txt",True) maxPwdAgeDays = GetMaxPwdAge(LDAPAD) CheckAndAlert()

 

Function CheckAndAlert()

On Error Resume Next Const ADS_SCOPE_SUBTREE = 3 Set objRootDSE = GetObject(LDAP://xxxx.com) 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") = ADS_SCOPE_SUBTREE objCommand.CommandText = "SELECT * FROM 'LDAP://xxxx.com' WHERE objectCategory='user'" Set objRecordSet = objCommand.Execute objRecordSet.MoveFirst Do Until objRecordSet.EOF  'WScript.Sleep  300         username = objRecordSet.Fields("ADsPath").Value                          LDAPUser=username      CheckPasswordExpire LDAPUser, maxPwdAgeDays, alertDays         'Wscript.Echo LDAPUser         objRecordSet.MoveNext Loop file.Close 'Wscript.Echo "" 'Wscript.Echo "Total User: "&objRecordSet.RecordCount 'WScript.Sleep  10000 End Function

Function CheckPasswordExpire(LDAPUser, maxPwdAgeDays, alertDays) On Error Resume Next  Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000  Const E_ADS_PROPERTY_NOT_FOUND  = &h8000500D  Const ONE_HUNDRED_NANOSECOND    = .000000100  Const SECONDS_IN_DAY            = 86400  If maxPwdAgeDays = 0 Then   Exit Function  Else   Set objUser = GetObject(LDAPUser)

  intUserAccountControl = objUser.Get("userAccountControl")

  If intUserAccountControl And ADS_UF_DONT_EXPIRE_PASSWD Then      Exit Function   Else      dtmValue = objUser.PasswordLastChanged        If Err.Number = E_ADS_PROPERTY_NOT_FOUND Then             Exit Function        Else           intTimeInterval = Int(Now - dtmValue)        End If          If intTimeInterval >= maxPwdAgeDays Then         Exit Function        Else            intTimeDaysFrom = Int((dtmValue + maxPwdAgeDays) - Now)         IF intTimeDaysFrom <= alertDays Then          mail = objUser.Get("mail")                                         file.writeline mail&","&intTimeDaysFrom&","&dtmValue&","&maxPwdAgeDays&","&LDAPUser      IF mail <> ""  Then                                                 'Wscript.Echo mail                                                 SendMail(mail)      END IF         End If        End If       End If  End If End Function

Function GetMaxPwdAge(LDAPAD)

 Const ONE_HUNDRED_NANOSECOND = .000000100   ' .000000100 is equal to 10^-7  Const SECONDS_IN_DAY = 86400  Set objDomain = GetObject(LDAPAD)  Set objMaxPwdAge = objDomain.Get("maxPwdAge")        

 If objMaxPwdAge.LowPart = 0 Then

  GetMaxPwdAge=0  Else   dblMaxPwdNano = Abs(objMaxPwdAge.HighPart * 2^32 + objMaxPwdAge.LowPart)   dblMaxPwdSecs = dblMaxPwdNano * ONE_HUNDRED_NANOSECOND   ' LINE 13   dblMaxPwdDays = Int(dblMaxPwdSecs / SECONDS_IN_DAY)      ' LINE 14   GetMaxPwdAge = dblMaxPwdDays  End If End Function

Sub SendMail(mailTo)

 On Error Resume Next  Set objMessage = CreateObject("CDO.Message")  objMessage.Subject = "您的域帐号密码即将过期,请及时更改!"  objMessage.From = mailFrom  objMessage.To = mailTo  objMessage.TextBody = "您的域帐号密码即将过期,请及时更改!!"&mailTo  objMessage.Configuration.Fields.Item("") = 2  objMessage.Configuration.Fields.Item("") = smtpserver  objMessage.Configuration.Fields.Item("") = sendusername  objMessage.Configuration.Fields.Item("") = Base64Decode(sendpassword)  objMessage.Configuration.Fields.Item("") = smtpserverport  objMessage.Configuration.Fields.Item("") = False  objMessage.Configuration.Fields.Item("") = 60  objMessage.Configuration.Fields.Update  objMessage.Send End Sub

Function Base64Decode(ByVal base64String)

  Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"   Dim dataLength, sOut, groupBegin   'remove white spaces, If any   base64String = Replace(base64String, vbCrLf, "")   base64String = Replace(base64String, vbTab, "")   base64String = Replace(base64String, " ", "")   'The source must consists from groups with Len of 4 chars   dataLength = Len(base64String)   If dataLength Mod 4 <> 0 Then     Err.Raise 1, "Base64Decode", "Bad Base64 string."     Exit Function   End If   ' Now decode each group:   For groupBegin = 1 To dataLength Step 4     Dim numDataBytes, CharCounter, thisChar, thisData, nGroup, pOut     ' Each data group encodes up To 3 actual bytes.     numDataBytes = 3     nGroup = 0     For CharCounter = 0 To 3       ' Convert each character into 6 bits of data, And add it To       ' an integer For temporary storage.  If a character is a '=', there       ' is one fewer data byte.  (There can only be a maximum of 2 '=' In       ' the whole string.)       thisChar = Mid(base64String, groupBegin + CharCounter, 1)       If thisChar = "=" Then         numDataBytes = numDataBytes - 1         thisData = 0       Else         thisData = InStr(1, Base64, thisChar, vbBinaryCompare) - 1       End If       If thisData = -1 Then         Err.Raise 2, "Base64Decode", "Bad character In Base64 string."         Exit Function       End If       nGroup = 64 * nGroup + thisData     Next     'Hex splits the long To 6 groups with 4 bits     nGroup = Hex(nGroup)     'Add leading zeros     nGroup = String(6 - Len(nGroup), "0") & nGroup     'Convert the 3 byte hex integer (6 chars) To 3 characters     pOut = Chr(CByte("&H" & Mid(nGroup, 1, 2))) + _       Chr(CByte("&H" & Mid(nGroup, 3, 2))) + _       Chr(CByte("&H" & Mid(nGroup, 5, 2)))     'add numDataBytes characters To out string     sOut = sOut & Left(pOut, numDataBytes)   Next   Base64Decode = sOut End Function