您的位置：首页 > 编程语言 > VB

用户密码在快过期时，发邮件提醒用户更改密码的脚本VBS

2012-03-16 16:14 1186 查看

转载的文章，觉得非常的实用，但是经过测试发现能够统计数据，不能够自动发送邮件，所以自己修改了一下，测试后正常发送邮件；

3月13修改，增加抄送邮件地址

大家都知道，在域环境中，组策略中可以设置当用户密码快过期时，电脑登录会有提示，但当用户出差，或是用OWA方式访问时，并不会收到相关提示，而导致道密码过期而无法收发邮件！

下面的方法，就是教大家，如何让用户密码在快过期时，发邮件提醒用户更改密码，让用户去OWA中去更改自已的密码，不至于发生密码过期，用户并不知道，而无法收发邮件！

以下是在AD、Exchange环境下，用邮件的方式通知用户密码到期提示的脚本，需要使用的，请将其路的Domainname.com和Domain改成你的域名，ADserver/Mailserver改为你的AD和Exchange的机器名，然后COPY下面的脚本存为.vbs格式，放在DC中，设置Scheduled Tasks，让其每天在固定时间执行！

注：此脚本文件会和组策略中的密码策略相对应

脚本内容：
'********************************************************************
'* Main Function:從AD中比對每一個使用者的Password LastSet,如果距離過期日剩30,15,3,2,1的使用者,則發信通知
'*
'* Usage:
' For Example : cscript QuerryAD.vbs
'*
'* Copyright (C) 2004 Microsoft Corporation
'********************************************************************
'Option Explicit

'For FileSystemObject
Const ForReading = 1
Const ForAppending = 8
Const ForWriting = 2
Const ADS_PROPERTY_DELETE = 4

dim arrWillExpiredDays

'Please modify the variable
CONST MASTERMAIL = "sysadmin@domainname.com" ‘需要修改发送邮件的地址
'const strSMTPServer = "mailserver"
'const strSendUserName = "domainname\sysadmin"
'const strSendPassword = "Password"
const strFullAdsiPath = ”LDAP://ADserver.domain.local/dc=domain,dc=com“ ‘需要修改域控服务器的地址。
arrWillExpiredDays = Array(30,7,3,2,1) '修改提醒邮件的发送日期

'Main Function

'Declare variables
Dim strTestMode
strTestMode = False 'use for debuging

'Cretae log file
Set WshSHell = CreateObject("Wscript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject")

strFileName = Replace(Datevalue(Now), "-", "_")
strFileName = Replace(strFileName, "/", "_")

Public fLog
Set oLog = objFSO.OpenTextFile(strFileName & ".txt", ForWriting, TRUE)

PrintScreen Now
PrintScreen ""

sta = ListWillExpireUsers()

PrintScreen sta

PrintScreen ""
PrintScreen "The command runs successfully!"
PrintScreen Now

oLog.Close

'Program ending
wscript.quit

'======================================
' Function Area
'======================================

'********************************************************************
'*
'* Function: PrintScreen
'* Purpose: Show Message
'* Input: Message
'*
'* Output: None
'*
'********************************************************************
Sub PrintScreen(strMessage)
if strTestMode = True then
Wscript.Echo strMessage
end if
oLog.WriteLine strMessage
End Sub

'********************************************************************
'*Function ListWillExpireUsers(nDays)
'* List all user objects whose password will be expired or is expired
'* nDays: how many days the password will be expired
'*
'*
'*
'*-------------------------------------------------------------------

Function ListWillExpireUsers()

Dim strMailAddress

' Create User Object
Set objConnection = CreateObject("ADODB.Connection")
Set objCommand = CreateObject("ADODB.Command")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand.ActiveConnection = objConnection

objCommand.CommandText = "<" & strFullAdsiPath & ">;(&(objectCategory=person)(objectclass=user));AdsPath,cn;subTree"
objCommand.Properties("Page Size") = 99 'specifies the maximum number of objects to return in a results set.

PrintScreen objCommand.CommandText
PrintScreen " "

Set objRecordSet = objCommand.Execute

If objRecordSet.RecordCount = 0 Then
PrintScreen "Error: Cannot found the user object in domain " & BaseDN & "."
Else

Dim intTotalAccount
intTotalAccount = 0

objRecordSet.MoveFirst

Do Until objRecordSet.EOF
intTotalAccount = intTotalAccount +1
'Retrive user information
Dim oUser

Set oUser = GetObject(objRecordSet.Fields("ADsPath").Value)

For Each oUserProperty in oUser
PrintScreen oUserProperty.Name
Next

If (oUser.AccountDisabled = FALSE) Then

PrintScreen vbTab & "User Name : " & oUser.Name
sStatus = UserPwdExpire(oUser)

Select Case sStatus

Case 999999
PrintScreen vbTab & " The user " & oUser.samaccountname & " Password never expires."

Case Else
if sStatus >= 0 then
strMSG = "Your password is already expired in " & sStatus & " days!"
PrintScreen vbTab & " The user " & oUser.samAccountName & " password is expired after " & sStatus & " days!"
elseif sStatus < 0 then
strMSG = "Your mail account password will be expired in " & 0-sStatus & " days!" & vbcrlf & "Please change your password as soon as possible!" ‘邮件内容
PrintScreen vbTab & " The user " & oUser.samAccountName & " password will be expired in " & 0-sStatus & " days!"
end if

For each checkDays in arrWillExpiredDays
if checkDays = (0-sStatus) then
call fnCheck_SendMail(oUser,strMSG)
end if
next
End Select

else
PrintScreen vbTab & "User Name : " & oUser.Name
PrintScreen vbTab & " The user " & oUser.samaccountname & " Account Disabled."
end if

objRecordSet.MoveNext

PrintScreen " "

Loop
End If
PrintScreen "Total Accounts is " & intTotalAccount

ListWillExpireUsers = "OK"

End Function

'********************************************************************
'* Function UserPwdExpire(objUser, nMaxPwdAge)
'* Check if user object password is or will be expired
'* objUser: the user object
'*
'* nMaxPwdAge: maximum password age of domain
'*
'*-------------------------------------------------------------------
Function UserPwdExpire(objUser)

On Error Resume Next
Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000
Const SEC_IN_DAY = 86400

intCurrentValue = objUser.Get("userAccountControl")

If intCurrentValue and ADS_UF_DONT_EXPIRE_PASSWD Then
'The password does not expire.
UserPwdExpire = 999999
Else

dtmValue = objUser.PasswordLastChanged
if err.number <> 0 then
dtmValue = 0
err.Clear
end if

PrintScreen vbTab & " The password was last changed on " & DateValue(dtmValue) & " at " & TimeValue(dtmValue)
'PrintScreen vbTab & "The password was last changed on " & _
'DateValue(dtmValue) & " at " & TimeValue(dtmValue) & VbCrLf & _
' "The difference between when the password was last set" & VbCrLf & _
' "and today is " & int(now - dtmValue) & " days"
intTimeInterval = int(now - dtmValue)

Set objSysInfo = CreateObject("ADSystemInfo")
strDomain = objSysInfo.DomainShortName
Set objSysInfo = Nothing

Set objDomainNT = GetObject("WinNT://" & strDomain)
intMaxPwdAge = objDomainNT.Get("MaxPasswordAge")

If intMaxPwdAge < 0 Then
'WScript.Echo "The Maximum Password Age is set to 0 in the " & _
'"domain. Therefore, the password does not expire."
Else
intMaxPwdAge = (intMaxPwdAge/SEC_IN_DAY)
'Wscript.echo "The maximum password age is " & intMaxPwdAge & " days"
If intTimeInterval >= intMaxPwdAge Then
'PrintScreen vbTab & "The password has expired."
UserPwdExpire = int(intTimeInterval - intMaxPwdAge)
Else
'PrintScreen vbTab & "The password will expire on " & _
' DateValue(dtmValue + intMaxPwdAge) & " (" & _
' int((dtmValue + intMaxPwdAge) - now) & " days from today" & ")."
UserPwdExpire = int(now - (dtmValue + intMaxPwdAge))
End If
End If
End If

End Function

'******************************
' Mail Message
'Reference : Creating and Sending a Message
'http://msdn.microsoft.com/library/en-us/cdosys/html/_cdosys_messaging_examples_creating_and_sending_a_message.asp?frame=true
'http://msdn.microsoft.com/library/en-us/cdosys/html/_cdosys_cdosendusing_enum.asp?frame=true
'******************************
Sub SendMail(strFrom, strTo, strSubject, strBodyText)

Dim iMsg
Set iMsg = CreateObject("CDO.Message")
Dim iConf
Set iConf = CreateObject("CDO.Configuration")

Dim Flds
Set Flds = iConf.Fields

With Flds
' assume constants are defined within script file
'.Item("cdoSendUsingMethod") = 2 ' cdoSendUsingPickup:1:Local , cdoSendUsingPort:2:Network
'.Item("cdoSendUsingPort") = 25 'cdoSendUsingPort
'.Item("cdoSMTPServer") = "mail.pcainv.com"
'.Item("cdoSMTPConnectionTimeout") = 10 ' quick timeout
'.Item("cdoSMTPAuthenticate") = cdoBasic
'.Item("cdoSendUserName") = "pca\yfu"
'.Item("cdoSendPassword") = "1234!Qaz"
'.Item("cdoURLProxyServer") = "tpeproxy:80"
'.Item("cdoURLProxyBypass") = "<local>"
'.Item("cdoURLGetLatestVersion") = True
'.Update
NameSpace = "http://schemas.microsoft.com/cdo/configuration/"
.Item(NameSpace&"sendusing") = 2
.Item(NameSpace&"smtpserver") = "mailserver" ’SMTP服务器地址
.Item(NameSpace&"smtpserverport") = 25 ‘SMTP服务器端口
.Item(NameSpace&"smtpauthenticate") = 1
.Item(NameSpace&"sendusername") = "Domainname\sysadmin" ’发信人用户名
.Item(NameSpace&"sendpassword") = "Password" ‘发信人密码
.Update
End With

With iMsg
Set .Configuration = iConf
.To = strTo
.From = strFrom
.Subject = strSubject
'.CreateMHTMLBody "This folder [" & strFolderPath & "] Created in " & intDayNum & " Days"
.TextBody = strBodyText
'.AddAttachment "C:\files\mybook.doc"

.CC = "sysadmin@domainname.com" '抄送邮件地址，可以选择管理员邮箱
.Send
End With

End Sub

'********************************************************************
'*
'* Function: fnCheck_SendMail
'* Purpose:
'* Input: objUser,MailMessage
'*
'* Output: None
'*
'********************************************************************
Function fnCheck_SendMail(objUser,strMSG)

'Send email
On Error Resume Next
Err.Clear

Dim PropArray

'PropArray = Array("proxyAddresses")
'oUser.GetInfoEx Array("proxyAddresses"), 0

aProxyAddress = objUser.GetEx("proxyAddresses")

If Err<>0 Then
PrintScreen vbTab & Time & " The user doesn't have email address."
Err.Clear
Else

For Each saProxyAddress in aProxyAddress

'Need a string variable to transfer the saProxyAddress
strMailAddress = saProxyAddress

ePos = Instr(1,strMailAddress,"SMTP:",VbTextCompare)

'PrintScreen vbTab & vbTab & "ePos = " & ePos

If ePos > 0 Then

strEmail = mid(strMailAddress,6)
PrintScreen vbTab & " Email Address: " & strEmail

'Use Exchange Server to send mail
SendMail MASTERMAIL, strEmail, "Password expiration notification!", strMSG

'If server installed the SMTP Service
'SendMessage MASTERMAIL, strEmail, "Password expiration notification!", strMSG

PrintScreen vbTab & " " & Time & " Finish sending email!"

Exit For

Else
'PrintScreen vbTab & vbTab & " No SMTP: string"
End If

Next

End If

end Function

'******************************************************************************
' Send messages with CDO for Windows 2000
' strTo: [in] To
' strFrom: [in] From
' strSubject: [in] Subject
' strBodyFile: [in] Body text file
'******************************************************************************
Sub SendMessage(strFrom, strTo, strSubject, strBodyText)

' For more information about CDO for Windows 2000, please refer to
' http://msdn.microsoft.com/library/en-us/exchanchor/htms/msexchsvr_cdowin2000.asp?frame=true
'On Error Resume Next
Dim oMessage ' as CDO.Message
Set oMessage = CreateObject("CDO.Message")

oMessage.TextBody = strBodyText
oMessage.To = strTo
oMessage.From = strFrom
oMessage.Subject = strSubject
Err.Clear
oMessage.Send

If Err.number <> 0 then
Wscript.Echo "Error in SendMessage: id=" & Err.number & ", source=" & Err.Source & ",Desc=" & Err.Description
Err.Clear
End If
Set oMessage = nothing

End Sub

内容来自用户分享和网络整理，不保证内容的准确性，如有侵权内容，可联系管理员处理

标签：

相关文章推荐

新的分享

章节导航