源代码：

On Error Resume Next
Const LDAPAD = "LDAP://DC=xxxx,DC=com"
Const alertDays = 7
Const path = "d:\alluser.txt"
Const mailFrom = "xxxx@xxxx.com"
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("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
 objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtpserver
 objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sendusername
 objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Base64Decode(sendpassword)
 objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = smtpserverport
 objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
 objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 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