続・Windows標準機能だけで、ディスクの残容量を監視する

windowsserver

systemmanagemant

vbs

以前にパフォーマンスモニタとタスクを使ってディスク容量を監視する方法をまとめたのですが、これには SMTP Auth に対応していないという致命的な問題があったので、何とかするべく調べてみたところ VBS を使って実現するのが良さそうだったので、サンプルを拝借して自分なりにまとめてみました。この機会に CDO で任意のヘッダを設定する方法もわかったのでいい勉強になりました。

こちらは vbs なので、やろうと思えばいろいろとカスタマイズが効きますからプログラムが得意な人にはオススメです。

† 開発したスクリプト

設定項目については適宜書き換えてください。
メールは Gmail 経由で送ることを想定していますが、それ以外でも送れるはずです。

DiskUsageAlert.vbs

Option Explicit

Dim WarningCount
Dim ServerName
Dim MailSubject
Dim MailBody
Dim UsageThreshold
Dim SmtpHost
Dim SmtpPort
Dim SmtpSSL
Dim SmtpUser
Dim SmtpPassword
Dim SmtpFrom
Dim SmtpTo

ServerName = "Example Server"
UsageThreshold = 90
SmtpFrom = "DiskUsageAlert <from@example.jp>"
SmtpTo = "to@example.jp"
SmtpHost = "smtp.gmail.com"
SmtpSSL = True
SmtpPort = 465
SmtpUser = "from@example.com"
SmtpPassword = "from_at_example_com_password"

MailSubject = "[Warning] ディスク容量監視アラート(" & UsageThreshold & "%超過): " & ServerName
WarningCount = 0

Dim objWMIService
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Dim objSWbemObjectCollection
Set objSWbemObjectCollection = objWMIService.ExecQuery("Select * from Win32_LogicalDisk Where DriveType = 3")
Dim objSWbemObject
For Each objSWbemObject in objSWbemObjectCollection
    Dim DeviceID
    Dim Size
    Dim FreeSpace
    Dim ExistPersent
    Dim Caution
    DeviceID = objSWbemObject.DeviceID
    Size = objSWbemObject.Size
    FreeSpace = objSWbemObject.FreeSpace
    ExistPersent = 100 - FreeSpace / Size * 100
    If ( ExistPersent > CDbl(UsageThreshold) ) Then
        Caution = "CAUTION!!!"
        WarningCount = WarningCount + 1
    Else
        Caution = ""
    End If

    MailBody = MailBody & DeviceID & vbTab & Int(FreeSpace / 1024 / 1024) _
        & "MB" & vbTab & Int(Size / 1024 / 1024) & "MB" & vbTab _
        & Int(ExistPersent) & "%" & vbTab & Caution & vbCrLf
Next

If ( WarningCount > 0 ) Then
  Call SendMail(SmtpFrom, SmtpTo, MailSubject , MailBody )
End IF

Sub SendMail(FromMailAddress, ToMailAddress, Subject, Body )
    Dim objConfig
    Set objConfig = CreateObject("CDO.Configuration")
    objConfig.Fields.Item( "http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    objConfig.Fields.Item( "http://schemas.microsoft.com/cdo/configuration/smtpusessl") = SmtpSSL
    objConfig.Fields.Item( "http://schemas.microsoft.com/cdo/configuration/smtpserver") = SmtpHost
    objConfig.Fields.Item( "http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SmtpPort

    'ユーザー認証
    objConfig.Fields.Item( "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    objConfig.Fields.Item( "http://schemas.microsoft.com/cdo/configuration/sendusername") = SmtpUser
    objConfig.Fields.Item( "http://schemas.microsoft.com/cdo/configuration/sendpassword") = SmtpPassword

    objConfig.Fields.Update
    
    Dim objMessage
    Set objMessage = CreateObject("CDO.Message")    
    Set objMessage.Configuration = objConfig

    objMessage.BodyPart.Charset = "utf-8"
    objMessage.Fields.Item("urn:schemas:mailheader:Precedence") = "bulk"
    objMessage.Fields.Item("urn:schemas:mailheader:X-Mailer") = "CLES MailNotice vbs"
    objMessage.Fields.Update

    objMessage.From = FromMailAddress
    objMessage.To = ToMailAddress
    objMessage.Subject = Subject
    objMessage.TextBody = Body

    objMessage.Send

'   If Err.Number = 0 Then
'       WScript.Echo "メールを送信しました。"
'   Else
'       WScript.Echo "メールの送信に失敗しました。" & _
'           "(" & Err.Description & ")"
'   End If
End Sub

† 飛んでくるメール

起動させたときに閾値を上回る領域が存在すれば下記のようなメールが飛んできます。
あとはタスクに登録して、一定時間ごとにまわしてやればOKです。

Subject: [Warning] ディスク容量監視アラート(90%超過):Example Server
From: DiskUsageAlert <from@example.jp>
To: to@example.jp

F:	5939MB	49999MB	88%	
G:	13535MB	903656MB	98%	CAUTION!!!
M:	2003878MB	3815248MB	47%	

† 参考

　・スクリプトとタスクによるサーバ監視の自動化（3/3）：CodeZine
　・VBScript Tips (Tips0203)