Many e-mailed me for these scripts so here they are. They check for user accounts that will expire within 14 days then sends an e-mail to all the users letting them know with a link to our intranet to change their password. - Josh
-----Original Message----- From: [EMAIL PROTECTED] [mailto:[EMAIL PROTECTED] On Behalf Of Shields, Anthony Sent: Tuesday, April 05, 2005 11:14 AM To: Exchange Discussions Subject: RE: Password expiration popup -OT Can we get a copy of the script? Would be interested in seeing how it works. Thanks, Tony As requested: 1st script followed by the 2nd script- Josh Option Explicit Const ForWriting = 2 Dim strFileName, strNTName, objShell, lngBiasKey, lngBias, k Dim objRootDSE, strDNSDomain, objDomain, objMaxPwdAge, intMaxPwdAge Dim objDate, dtmPwdLastSet, lngFlag, blnPwdExpire Dim lngHighAge, lngLowAge, lngDate, dtmPwdExpires Dim objConnection, objCommand, objRecordSet Dim strFilter, strQuery Dim strEmail, objEmail, strEmailAddr Const ADS_UF_PASSWD_CANT_CHANGE = &H40 Const ADS_UF_DONT_EXPIRE_PASSWD = &H10000 ' Specify the file of email addresses. strFileName = "D:\pwd\MailTo.txt" Set fso = CreateObject("Scripting.FileSystemObject") Set tf = fso.CreateTextFile(strFileName, True) ' Obtain local time zone bias from machine registry. set objShell = CreateObject("Wscript.Shell") lngBiasKey = objShell.RegRead("HKLM\System\CurrentControlSet\Control\" & "TimeZoneInformation\ActiveTimeBias") If UCase(TypeName(lngBiasKey)) = "LONG" Then lngBias = lngBiasKey ElseIf UCase(TypeName(lngBiasKey)) = "VARIANT()" Then lngBias = 0 For k = 0 To UBound(lngBiasKey) lngBias = lngBias + (lngBiasKey(k) * 256 ^ k) Next End If ' Determine domain maximum password age policy in days. set objRootDSE = GetObject("LDAP://RootDSE";) strDNSDomain = objRootDSE.Get("DefaultNamingContext") set objDomain = GetObject("LDAP://"; & strDNSDomain) set objMaxPwdAge = objDomain.MaxPwdAge ' Account for bug in IADslargeInteger property methods. lngHighAge = objMaxPwdAge.HighPart lngLowAge = objMaxPwdAge.LowPart If lngLowAge < 0 Then lngHighAge = lngHighAge + 1 End If intMaxPwdAge = -((lngHighAge * 2 ^ 32) _ + lngLowAge) / (600000000 * 1440) ' Use ADO to search the domain for all users. set objConnection = CreateObject("ADODB.Connection") set objCommand = CreateObject("ADODB.Command") objConnection.Provider = "ADsDSOOBject" objConnection.Open("Active Directory Provider") objCommand.ActiveConnection = objConnection ' Filter to retrieve all user objects. strFilter = "(&(objectCategory=person)(objectClass=user))" strQuery = "<LDAP://"; & strDNSDomain & ">;" & strFilter & ";sAMAccountName,pwdLastSet,userAccountControl,mail;subtree" objCommand.CommandText = strQuery objCommand.Properties("Page Size") = 10000 objCommand.Properties("Timeout") = 60 objCommand.Properties("Cache Results") = False ' Enumerate all users. For users whose password can expire, ' determine when the password expires. set objRecordSet = objCommand.Execute Do Until objRecordSet.EOF strNTName = objRecordSet.Fields("sAMAccountName") strEmailAddr = objRecordSet.Fields("mail") 'msgbox strNTName lngFlag = objRecordSet.Fields("userAccountControl") blnPwdExpire = True If (lngFlag And ADS_UF_PASSWD_CANT_CHANGE) <> 0 Then blnPwdExpire = False End If If (lngFlag And ADS_UF_DONT_EXPIRE_PASSWD) <> 0 Then blnPwdExpire = False End If ' Only continue if the password can expire. If blnPwdExpire = True Then 'msgbox "can expire" ' Determine when password last set. lngDate = objRecordSet.Fields("pwdLastSet") set objDate = lngDate dtmPwdLastSet = Integer8Date(objDate, lngBias) ' Continue only if password was ever set. 'msgbox "dtmPwdLastSet " & dtmPwdLastSet If dtmPwdLastSet > #1/1/1601# Then ' Determine when the password expires. dim lngage 'lngAge = objRecordSet.Fields("MaxPwdAge") 'set objage = lngAge dtmPwdExpires = DateAdd("d", intMaxPwdAge, dtmPwdLastSet) 'msgbox "dtmPwdExpires "& dtmPwdExpires ' Determine if password expires within the next 14 days. If dtmPwdExpires < DateAdd("d", 14, Now) Then 'msgbox "dtmPwdExpires is less than dataAdd 14" ' If dtmPwdExpires < Now Then ' 'msgbox "' Password already expired." ' Else 'msgbox" 'Password expires in the next 14 days." ' 'msgbox "Create a text document here, and once a day send it out and clear" ''msgbox strEmailAddr if strEmailAddr <> "" then Dim fso, tf 'Set fso = CreateObject("Scripting.FileSystemObject") 'Set tf = fso.OpenTextFile(strFileName, ForWriting, True) tf.WriteLine(strEmailAddr) tf.WriteLine(dtmPwdExpires) 'msgbox "Just wrote " & strEmailAddr & " to file" end if strEmail = strFileName end if end if end if objrecordset.movenext 'msgbox "loop" loop tf.Close objconnection.close 'msgbox "Account_Expire_List script Complete" Function Integer8Date(objDate, lngBias) 'msgbox "in Func" ' Function to convert Integer8 (64-bit) value to a date, adjusted for ' local time zone bias. Dim lngAdjust, lngDate, lngHigh, lngLow lngAdjust = lngBias lngHigh = objDate.HighPart lngLow = objdate.LowPart ' Account for error in IADslargeInteger property methods. If lngLow < 0 Then lngHigh = lngHigh + 1 End If If (lngHigh = 0) And (lngLow = 0) Then lngAdjust = 0 End If lngDate = #1/1/1601# + (((lngHigh * (2 ^ 32)) _ + lngLow) / 600000000 - lngAdjust) / 1440 ' Trap error if lngDate is ridiculously huge. On Error Resume Next Integer8Date = CDate(lngDate) If Err.Number <> 0 Then On Error GoTo 0 Integer8Date = #1/1/1601# End If On Error GoTo 0 End Function ------------------------------------------------------------------------ ----------------------------- Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"; Const cdoSendUsingPort = 2 Const cdoSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"; Const cdoSMTPServerPort ="http://schemas.microsoft.com/cdo/configuration/smtpserverport"; Const cdoSMTPConnectionTimeout = "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"; Const cdoSMTPAuthenticate = "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate"; Const cdoBasic = 1 Const cdoSendUserName = "http://schemas.microsoft.com/cdo/configuration/sendusername"; Const cdoSendPassword = "http://schemas.microsoft.com/cdo/configuration/sendpassword"; dim filesys, text, readfile, contents, col, linumber, strExpire set filesys = CreateObject("Scripting.FileSystemObject") set readfile = filesys.OpenTextFile("D:\pwd\MailTo.txt", 1, false) do while readfile.AtEndOfStream <> true strEmial = readfile.readline strExpire = readfile.readline 'msgbox strExpire 'Send message 'SmtpMail.SmtpServer = "winnie.consovo.com" dim objMessage Set objMessage = CreateObject("CDO.Message") Dim iConf Set iConf = CreateObject("CDO.Configuration") Dim flds Set flds = iconf.fields With flds .Item(cdoSendUsingMethod) = cdoSendUsingPort 'Replace with your SMTP server .Item(cdoSMTPServer) = "winnie.consovo.com" .Item(cdoSMTPServerPort) = 25 .Item(cdoSMTPConnectionTimeout) = 100 'Only used if SMTP server requires Authentication .Item(cdoSMTPAuthenticate) = cdoBasic .Item(cdoSendUserName) = "passwordreset" .Item(cdoSendPassword) = "pass123" .Update End With With objMessage Set .Configuration = iConf .To = strEmial .Bcc = "[EMAIL PROTECTED]" .From = "[EMAIL PROTECTED]" .Subject = "ACTION REQUIRED:Password Reset " .TextBody = "Your desktop password to access the Consovo corporate network is about to expire on:" & strExpire & "." & vbCrLf & vbCrLf & _ "If you fail to reset your password you may be locked out of the Consovo network and may need the assistance of the Consovo Help Desk." & vbCrLf & vbCrLf & _ "Please click on the below link to review the password guidelines and to reset your password immediately." & vbCrLf & vbCrLf & _ "<https://login.consovo.net/authgui/changepassword.aspx>" & vbCrLf & vbCrLf & _ "Any questions, please call the Help Desk 415 5294 4321 or your local support group." '.CreateMHTMLBody "http:\\testurl.com" '.AddAttachment "C:\files\mybook.doc" .Send End With loop set readfile = filesys.getfile("D:\pwd\MailTo.txt") readfile.delete 'readfile.close ' msgbox "SendMail script complete" -----Original Message----- From: [EMAIL PROTECTED] [mailto:[EMAIL PROTECTED] On Behalf Of Horner, Josh Sent: Tuesday, April 05, 2005 11:07 AM To: Exchange Discussions Subject: RE: Password expiration popup -OT We use a script that runs every day that looks for accounts that are about to expire (14 days) and another script that takes the output and then e-mails all users whose password will expire with 14 days with a link to reset it. The e-mail includes a link to reset their password. Free solution, just some scripting time. - Josh -----Original Message----- From: [EMAIL PROTECTED] [mailto:[EMAIL PROTECTED] On Behalf Of BW Brandt Ward (5320) Sent: Tuesday, April 05, 2005 10:46 AM To: Exchange Discussions Subject: Password expiration popup -OT We have many remote offices where people are logging in locally to their pc's and authenticate to our domain when they open up outlook. These people never get the popup telling them that their network password is going to expire. I know if I put DC's in each office and have them authenticate to our domain they will see them but that is not something I can do right away. Does anyone know of any third party or even MS tool that can provide this password expiration popup? All these remote offices are connected to HQ via VPN tunnel. We run 2003 AD with exch 2003 with outlook 2003 on the clients. Not sure if there is a setting somewhere that will prompt them after they auth. Into outlook. Any help would be apprecaited. _________________________________________________________________ List posting FAQ: http://www.swinc.com/resource/exch_faq.htm Web Interface: http://intm-dl.sparklist.com/read/?forum=exchange To subscribe: http://e-newsletters.internet.com/discussionlists.html/ To unsubscribe send a blank email to [EMAIL PROTECTED] Exchange List admin: [EMAIL PROTECTED] To unsubscribe via postal mail, please contact us at: Jupitermedia Corp. Attn: Discussion List Management 475 Park Avenue South New York, NY 10016 Please include the email address which you have been contacted with. _________________________________________________________________ List posting FAQ: http://www.swinc.com/resource/exch_faq.htm Web Interface: http://intm-dl.sparklist.com/read/?forum=exchange To subscribe: http://e-newsletters.internet.com/discussionlists.html/ To unsubscribe send a blank email to [EMAIL PROTECTED] Exchange List admin: [EMAIL PROTECTED] To unsubscribe via postal mail, please contact us at: Jupitermedia Corp. Attn: Discussion List Management 475 Park Avenue South New York, NY 10016 Please include the email address which you have been contacted with. _________________________________________________________________ List posting FAQ: http://www.swinc.com/resource/exch_faq.htm Web Interface: http://intm-dl.sparklist.com/read/?forum=exchange To subscribe: http://e-newsletters.internet.com/discussionlists.html/ To unsubscribe send a blank email to [EMAIL PROTECTED] Exchange List admin: [EMAIL PROTECTED] To unsubscribe via postal mail, please contact us at: Jupitermedia Corp. Attn: Discussion List Management 475 Park Avenue South New York, NY 10016 Please include the email address which you have been contacted with. _________________________________________________________________ List posting FAQ: http://www.swinc.com/resource/exch_faq.htm Web Interface: http://intm-dl.sparklist.com/read/?forum=exchange To subscribe: http://e-newsletters.internet.com/discussionlists.html/ To unsubscribe send a blank email to [EMAIL PROTECTED] Exchange List admin: [EMAIL PROTECTED] To unsubscribe via postal mail, please contact us at: Jupitermedia Corp. Attn: Discussion List Management 475 Park Avenue South New York, NY 10016 Please include the email address which you have been contacted with.
