ドメインユーザのパスワード有効期限更新通知を積極的に促す

Option Explicit
    Dim WSH, wExec, sCmd, Return
    Dim FSO, UserHome, PWCHK_Path

    Set WSH = CreateObject("WScript.Shell")
    Set FSO = CreateObject("Scripting.FileSystemObject")

'タスクスケジューラーにPWExpireCheckが登録されているか確認
'未登録の場合は、スケジュール登録、必要ファイルをローカルにコピーする。
    sCmd = "schtasks /query /tn PWExpireCheck10"
    Return = WSH.Run("%ComSpec% /c " & sCmd, 0)

    If Return = 0 Then

'Get User home directory
    UserHome = WSH.ExpandEnvironmentStrings("%USERPROFILE%")

'【## 変更箇所 ##】PWMSG/PWGETファイルをユーザフォルダにコピー保存
    FSO.CopyFile "\\fs\UserPWchk\PWMSG.vbs", UserHome & "\", true
    FSO.CopyFile "\\fs\UserPWchk\PWGET.vbs", UserHome & "\", true

'PWGETを実行しパスワード有効期限ファイルを作成
    sCmd = FSO.BuildPath(UserHome, "\PWGET.vbs")
    WSH.Run "%ComSpec% /c " & sCmd, 0

'タスクスケジューラの登録(実際は、5分前通知)
    PWCHK_Path = FSO.BuildPath(UserHome, "\PWMSG.vbs")
    sCmd = "schtasks /create /tn PWExpireCheck10 /tr """ & PWCHK_Path & """ /sc weekly /d mon,tue,wed,thu,fri /st 9:55 /F"
    WSH.Run "%ComSpec% /c " & sCmd, 0
    sCmd = "schtasks /create /tn PWExpireCheck12 /tr """ & PWCHK_Path & """ /sc weekly /d mon,tue,wed,thu,fri /st 11:55 /F"
    WSH.Run "%ComSpec% /c " & sCmd, 0
    sCmd = "schtasks /create /tn PWExpireCheck14 /tr """ & PWCHK_Path & """ /sc weekly /d mon,tue,wed,thu,fri /st 13:55 /F"
    WSH.Run "%ComSpec% /c " & sCmd, 0
    sCmd = "schtasks /create /tn PWExpireCheck16 /tr """ & PWCHK_Path & """ /sc weekly /d mon,tue,wed,thu,fri /st 15:55 /F"
    WSH.Run "%ComSpec% /c " & sCmd, 0

   End If

    Set wExec = Nothing
    Set FSO = Nothing
    Set WSH = Nothing

Option Explicit
    Dim WSH, FSO, wExec, PWE_File
    Dim sCmd, UserHome, input, str_tmp, Expires_date, Lang, Expire, PWE_Path

    Set WSH = CreateObject("WScript.Shell")
    Set FSO = CreateObject("Scripting.FileSystemObject")

'Get User home directory
    UserHome = WSH.ExpandEnvironmentStrings("%USERPROFILE%")

'Get Account informations of Logon user
    sCmd = "net user %USERNAME% /domain"
    Set wExec = WSH.Exec("%ComSpec% /c " & sCmd)

    Do While Not wExec.StdOut.AtEndOfStream

     input = wExec.StdOut.ReadLine

'Get "有効期間" colum, if japanese OS
     If InStr(input, "有効期間") > 0 Then
 	str_tmp = input
	Lang = "JP"
     End If

'Get "Password expires" colum, if English OS
     If InStr(input, "Password expires") > 0 Then
 	str_tmp = input
	Lang = "EN"
     End If

'Get "암호 만료 날짜" colum, if English OS
     If InStr(input, "암호 만료 날짜") > 0 Then
 	str_tmp = input
	Lang = "KR"
     End If

    Loop

'パスワード有効期間までの残り日数を計算
    if InStr(str_tmp, "?") > 0 Then
		str_tmp = Replace(str_tmp, "?", "")
	End If

    Expires_date = Split(str_tmp, " ")

    If Lang = "JP" Then
	Expire = Expires_date(19)
    End If

    If Lang = "EN" Then
	Expire = Expires_date(14)
    End If

    If Lang = "KR" Then
	Expire = Expires_date(23)
    End If

'パスワード有効期間情報をファイル保存
    PWE_Path = FSO.BuildPath(UserHome, "\PasswordExpire.txt")
    Set PWE_File = FSO.CreateTextFile(PWE_Path, True)
    PWE_File.Writeline(Expire)
    PWE_File.Close()

    Set wExec = Nothing
    Set PWE_File = Nothing
    Set FSO = Nothing
    Set WSH = Nothing

Option Explicit
    Dim WSH, FSO, TextFile  
    Dim UserHome, PWNoticeDays, PWE_Path, str_tmp, Expires_date, sCmd, AttMsg

'【## 変更箇所 ##】パスワード有効期限メッセージ通知する日数
    PWNoticeDays = 20

    Set WSH = CreateObject("WScript.Shell")
    Set FSO = CreateObject("Scripting.FileSystemObject")

'Get User home directory
     UserHome = WSH.ExpandEnvironmentStrings("%USERPROFILE%")

'Get Password expires date from PasswordExpire.txt
    PWE_Path = FSO.BuildPath(UserHome, "\PasswordExpire.txt")
On Error Resume Next
    Set TextFile = FSO.OpenTextFile(PWE_Path,1)

    If Err.Number = 0 Then
       str_tmp = TextFile.ReadLine()

'パスワード有効期間までの残り日数を計算
       Expires_date = DateDiff("d", Now, str_tmp)

'Expire_dateがxx日以内ならパスワード有効期限を再取得
       If Expires_date < PWNoticeDays Then
          sCmd = FSO.BuildPath(UserHome, "\PWGET.vbs")
          WSH.Run "%ComSpec% /c " & sCmd, 0
          Set TextFile = FSO.OpenTextFile(PWE_Path,1)
          If Err.Number = 0 Then
             str_tmp = TextFile.ReadLine()
             Expires_date = DateDiff("d", Now, str_tmp)
          End If
       End If

'Expire_dateがxx日以内ならメッセージボックスを表示
       If Expires_date < PWNoticeDays Then

'【## 変更箇所 ##】ポップアップメッセージ文
          AttMsg = "     Your password will expire in " & Expires_date & " days" & vbCrLf & vbCrLf _
                   & "Please change your password before it expires." & vbCrLf _
                   & "                                     - IT Team -"
'メッセージボックス表示
          MsgBox AttMsg, vbExclamation Or vbSystemModal, "Password Expiration"
       End If
    Else 
        sCmd = FSO.BuildPath(UserHome, "\PWGET.vbs")
        WSH.Run "%ComSpec% /c " & sCmd, 0
        Set TextFile = FSO.OpenTextFile(PWE_Path,1)
    End If

    TextFile.Close()
    Set TextFile = Nothing
    Set FSO = Nothing
    Set WSH = Nothing

Option Explicit
On Error Resume Next

'【## 変更箇所 ##】基本設定
'-----------------------------------------------------------------------------------------
'ドメイン名
Const Domain = "xxxx.co.jp"
 
'パスワード変更通知期限（この日数以下になるとユーザーへ通知します）
Const NotifyLimit = 10
 
'メール送信設定
'SMTPサーバ
Const SmtpServer = "mail.xxxx.co.jp"
 
'送信元メールアドレス（From）
Const MailFrom = "nortice@xxxx.co.jp"
 
'メール件名
Const MailSubJect = "Password expiration notice"
 
'既定のメールアドレス（ユーザーのメールアドレスが未登録の場合はこのアドレスへ通知）
Const DefaultTo = "nortice@xxxx.co.jp"
 
'SMTP認証情報
Const SmtpAuth = True
Const SmtpUser = "postmaster"
Const SmtpPassword = "password"
 
'除外ユーザー（セミコロン区切りでユーザー名を記載）
Const ExcludeUser = ""
'-----------------------------------------------------------------------------------------
 
Const ADS_UF_DONT_EXPIRE_PASSWD = &h10000
Dim cmdResult, strLogFile, strLine, strCmd, strUser, intUAC, strMailBody, i, j
Dim objShell, objFS, objFile, objUser
Dim arrUsers, intMaxPwdDays, dtmExpDay, intVal, MailTo
 
Set objShell = WScript.CreateObject("WScript.Shell")
Set objFS = WScript.CreateObject("Scripting.FileSystemObject")
objShell.CurrentDirectory = objFS.GetParentFolderName(WScript.ScriptFullName)
 
'全ユーザのパスワード有効期限一覧ファイルの初期化（このプログラムと同じディレクトリに保管）
strLogFile = "PWNotify.csv"
objFS.CreateTextFile strLogFile, True
Set objFile = objFS.OpenTextFile(strLogFile, 2)
objFile.WriteLine "User,E-Mail,PasswordLastChanged,ExpirationDate,Status"
objFile.Close
 
'Main Routine
'ユーザーのLDAPパス取得
arrUsers = Split(GetLdapPaths(Domain), ";")
 
'パスワード期限のチェック
For Each strUser In arrUsers
   Set objUser = GetObject(strUser)
 
   intUAC = objUser.Get("userAccountControl")

   '【## 変更箇所 ##】ユーザが格納されているOUだけ処理＆PW無期限ユーザは除外
   If InStr(objUser.distinguishedName, "OU=Users") > 0 then
     If intUAC And ADS_UF_DONT_EXPIRE_PASSWD Then
        '無期限ユーザーの処理
        strLine = objUser.sAMAccountName & "," & objUser.mail & "," & objUser.PasswordLastChanged & ",None,Permanent"
     Else
        intMaxPwdDays = GetMaxPwdDays(Domain)
        dtmExpDay = DateAdd("d", intMaxPwdDays, objUser.PasswordLastChanged)
        intVal = Int(intMaxPwdDays - (Now - objUser.PasswordLastChanged))
 
        '期限切れユーザーへメール送信
        If CheckExcludeUser(objUser.sAMAccountName, ExcludeUser) Then
           '除外ユーザーの処理
           strLine = objUser.sAMAccountName & "," & objUser.mail & "," & objUser.PasswordLastChanged & "," & dtmExpDay & ",Exclusion"
        Else
           If intVal <= NotifyLimit Then

              '【## 変更箇所 ##】メール送信対象ユーザーの処理　＆　メール本文内容
              strMailBody = "To: " & objUser.DisplayName & Chr(13) & Chr(10) & _
                                      Chr(13) & Chr(10) & _
                                      "Your password will expire in " & intVal & " day(s) at " & dtmExpDay & "(JST)." & Chr(13) & Chr(10) & _
                                      Chr(13) &Chr(10) & _
                                      "Please change your password before it expires." & Chr(13) & Chr(10) & _
                                       Chr(13) & Chr(10) & _
                                       Chr(13) & Chr(10)
                                       strMailBody = strMailBody & _
                                       "===== How to Change password =====" & Chr(13) & Chr(10) & _
                                       "1. Connect to Corporate Network!" & Chr(13) & Chr(13) & Chr(10) & _
                                       "2. Press Ctrl + Alt + Delete Key" & Chr(13) & Chr(13) & Chr(10) & _
                                       "3. Choose [Password change(c)] menu and [xxxxx" & chr(92) & "<Username>] icon (not bird graphic icon) " & Chr(13) & Chr(13) & Chr(10) & _
                                       "4. Type, Old Password & New Password twice" & Chr(13) & Chr(10) & _
                                       "   (alphabetical uppercase or lowercase, special character, numeric, 8characters and either 3types )"& Chr(13) & Chr(13) & Chr(10) & _
                                       "5. Finish!" & Chr(13) & Chr(10) & _
                                       Chr(13) &Chr(10) & _
                                       Chr(13) &Chr(10) & _
                                       "IT Team" & Chr(13) & Chr(10) & _
                                       "nortice@xxxx.co.jp" & Chr(13) & Chr(10)

              If Len(objUser.mail) = 0 Then
                 MailTo = DefaultTo
              Else
                 MailTo = objUser.mail & "," & DefaultTo
              End If

              'メール送信実行
              cmdResult = SendMsg(SmtpServer, SmtpUser, SmtpPassword, MailFrom, MailTo, MailSubject, strMailBody)
              If cmdResult Then
                 strLine = objUser.sAMAccountName & "," & objUser.mail & "," & objUser.PasswordLastChanged & "," & dtmExpDay & ",Send Mail"
              Else
                 strLine = objUser.sAMAccountName & "," & objUser.mail & "," & objUser.PasswordLastChanged & "," & dtmExpDay & ",Send Error"
              End If
           Else
              'メール送信対象外ユーザーの処理
              strLine = objUser.sAMAccountName & "," & objUser.mail & "," & objUser.PasswordLastChanged & "," & dtmExpDay & ",Not Expired"
           End If
        End If
     End If

     Set objFile = objFS.OpenTextFile(strLogFile, 8)
     objFile.WriteLine strLine
     objFile.Close
   End If
Next
 
WScript.Quit(0)
 
'Sub Routine
Function GetLdapPaths(Fqdn)
   Dim objConn, objCmd, objRecSet
   Dim arrDn, strDn, strOu, strPathLine, n
   arrDn = Split(Fqdn, ".")
   For n = 0 To UBound(arrDn)
      If n = 0 Then
         strDn = "DC=" & arrDn(n)
      Else
         strDn = strDn & ",DC=" & arrDn(n)
      End If
   Next

'【## 変更箇所 ##】ユーザOUを指定 (最後はカンマをつける)  
   strOu = "OU=Users,"

   Set objConn = CreateObject("ADODB.Connection")
   Set objCmd = CreateObject("ADODB.Command")
   objConn.Provider = "ADsDSOObject"
   objConn.Open "Active Directory Provider"
   objCmd.ActiveConnection = objConn
   '接続プロパティ
   objCmd.Properties("Page Size") = 1000
   objCmd.Properties("Timeout") = 30
   objCmd.Properties("Searchscope") = 5
   objCmd.Properties("Cache Results") = False
 
   objCmd.CommandText = "SELECT AdsPath FROM 'LDAP://" & strOu & strDn & "' WHERE objectCategory='user' ORDER BY pwdLastSet"
   Set objRecSet = objCmd.Execute
   objRecSet.MoveFirst
 
   strPathLine = objRecSet.Fields("AdsPath").Value
   objRecSet.MoveNext
   Do Until objRecSet.EOF
      strPathLine = strPathLine & ";" & objRecSet.Fields("AdsPath").Value
      objRecSet.MoveNext
   Loop
 
   objConn.Close
   Set objCmd = Nothing
 
   GetLdapPaths = strPathLine
End Function
 
'パスワード有効日数（ドメインポリシー）
Function GetMaxPwdDays(Fqdn)
   Dim objDom, objMaxPwdAge
   Dim arrDn, strDn, maxPwdNano, maxPwdSecs, n
   arrDn = Split(Fqdn, ".")
   For n = 0 To UBound(arrDn)
      If n = 0 Then
         strDn = "DC=" & arrDn(n)
      Else
         strDn = strDn & ",DC=" & arrDn(n)
      End If
   Next
    
   Set objDom = GetObject("LDAP://" & strDn)
   Set objMaxPwdAge = objDom.Get("maxPwdAge")
   GetMaxPwdDays = CCur((objMaxPwdAge.HighPart * 2 ^ 32) + objMaxPwdAge.LowPart) / CCur(-864000000000)
    
   Set objDom = Nothing
End Function
 
'除外ユーザー判定
Function CheckExcludeUser(TargetUser,ExcludeList)
   Dim arrExcludeUsers, tmpUser
   CheckExcludeUser = False
   arrExcludeUsers = Split(ExcludeList, ";")
   For Each tmpUser In arrExcludeUsers
      If LCase(tmpUser) = LCase(TargetUser) Then
         CheckExcludeUser = True
         Exit For
      End If
   Next
End Function
 
'メール送信
Function SendMsg(strSmtp, strSmtpUser, strSmtpPass, strFrom, strTo, strSubject, strBody)
   Dim objMsg, strSchem, intPort
   strSchem = "http://schemas.microsoft.com/cdo/configuration/"
   intPort = 25
   Set objMsg = CreateObject("CDO.Message")
 
   'SMTP認証を使用する場合
   If SmtpAuth Then
      objMsg.Configuration.Fields.Item(strSchem & "sendusername") = strSmtpUser
      objMsg.Configuration.Fields.Item(strSchem & "sendpassword") = strSmtpPass
      objMsg.Configuration.Fields.Item(strSchem & "smtpauthenticate") = 1
      'SMTP over SSLを使用する場合
      'objMsg.Configuration.Fields.Item(strSchem & "smtpusessl") = True
   End If
 
   'アドレス情報定義
   objMsg.From = strFrom
   objMsg.To = strTo
   'objMsg.Cc = strCc
   'objMsg.Bcc = strBcc
 
   '件名/本文定義/添付ファイル
   objMsg.Subject = strSubject
   objMsg.TextBody = strBody
   objMsg.TextBodyPart.Charset = "UTF-8"
   '添付ファイル
   'objMsg.AddAttachment(strAttacheFile)
 
   'SMTPサーバ定義
   objMsg.Configuration.Fields.Item(strSchem & "sendusing") = 2
   objMsg.Configuration.Fields.Item(strSchem & "smtpserver") = strSmtp
   objMsg.Configuration.Fields.Item(strSchem & "smtpserverport") = intPort
 
   'メール送信
   objMsg.Configuration.Fields.Update
   objMsg.Send
   If Err.Number = 0 or Err.Number = -2147463155 Then
      SendMsg = True
   Else
      SendMsg = False
   End If
End Function

REM パスワード通知メールを送信するプログラムのタスクスケジューラー登録バッチ
REM ADサーバ等のタスクスケジューラーで実行する。（タスクでユーザがログオフ時も実行にしている場合は、PWNotify.csvをFILEサーバに保管できないため。）
schtasks /create /tn PasswordExpireNotice06 /tr \\fs\UserPWchk\PWAlertML.vbs /ru SYSTEM /sc weekly /d mon,tue,wed,thu,fri /st 06:00 /F
schtasks /create /tn PasswordExpireNotice09 /tr \\fs\UserPWchk\PWAlertML.vbs /ru SYSTEM /sc weekly /d mon,tue,wed,thu,fri /st 09:00 /F
schtasks /create /tn PasswordExpireNotice12 /tr \\fs\UserPWchk\PWAlertML.vbs /ru SYSTEM /sc weekly /d mon,tue,wed,thu,fri /st 12:00 /F
schtasks /create /tn PasswordExpireNotice15 /tr \\fs\UserPWchk\PWAlertML.vbs /ru SYSTEM /sc weekly /d mon,tue,wed,thu,fri /st 15:00 /F
schtasks /create /tn PasswordExpireNotice18 /tr \\fs\UserPWchk\PWAlertML.vbs /ru SYSTEM /sc weekly /d mon,tue,wed,thu,fri /st 18:00 /F