ShutDownTimer VBS

1年半ぐらい前(Windows7が発売された当初)に書いたVBSスクリプトを掲載するぜ。
ブログにアップしようと思ってて忘れてた。ブログの記事内容も下書きしてたし。

ZIP download is hear

———-

この土日にWindows7をいじっていたのですが、Windows7では保護者による制限機能が除外されているんですね。であれば、以前Win32で少し取り組んだこともあって、自前で作ってしまおうということでノートPCに向かったのですが、考えてみればこのノートPCには開発環境が入ってないことに気がつきました。そこで、何かできないかなと少し考えてみるとテキストベースのスクリプトで作ることにしました。

VbScript(VBS)で作成しました。INIファイルの設定値に基づいて、一定時間起動した後シャットダウンするという、まあ簡易プログラムです。設定はINIファイルで行います。

以下にINIの設定値を説明します。
スクリプト本体は下部に掲載します。

——————–
[SettingTimes]
UseMinutes=90
IntervalMinutes=90
SleepStartTime=0:00:00
SleepEndTime=6:00:00
SaveDateTime=2009/09/14 0:51:21
——————–

UseMinutes=90
スクリプトを起動してからシャットダウンさせるまでの時間を分刻みで設定します。ここでは90分となっています。

IntervalMinutes=90
シャットダウンしてから次回のスクリプトを起動するまでの時間を分刻みで設定します。ここでは90分となっています。

SleepStartTime=0:00:00
何時から何時まではスリープにしたいときの設定です。何時からのからの部分を設定します。

SleepEndTime=6:00:00
何時から何時まではスリープにしたいときの設定です。何時からのまでの部分を設定します。

SaveDateTime=2009/09/14 0:51:21
この項目はプログラムが保管用として保持しますので設定する必要はありません。意図的に前回のシャットダウン時刻を操作する場合は書き換えてください。形式はDate形で上述のようになります。

使い方ですが、このスクリプトで想定されるユーザーは、管理者権限のある人が、たとえば子どものパソコンの使用時間を制限するといったことが考えられます。このスクリプトに対するショートカットをスタートアップに作成し、スクリプト本体と設定用のINIファイルを管理者権限が必要なフォルダに置くのが最良です。パソコンに詳しい人だと簡単に解除されてしまうことが容易に予想されますが、さらに手の込んだやり方としてはこのVBSをショートカットに埋め込むとかすればできるかも・・・。おっと、これ以上書くと、ウイルスの作り方を説明することになってしまいそうなので、後はご自由に。

スクリプト実行中に表示されるぽっぷあっぷダイアログは指定時間経過後に自動的に閉じるようになっています。こうしないとダイアログが表示されていれさえすれば起動をストップされてしまいますので。

スクリプト本体にコメントを入れていますのでご自由にカスタマイズして使ってください。

結局Win32APIと同じぐらいの時間がかかってしまいました。コード量は、もう少しWin32の方が多くなり、コールバックの記述などで処理を示す必要がありますね。

それにしても、こうしてVBSで書いてみると、なるべく見通しのよいように書きましたが、VBSの限界というかどうしても、コードとしては美しくないところが所々ありますね。今時のVB.NETだと、かなりコードをオブジェクト指向で整理できて美しくコーディングできるのですが、旧いスタイルのVBSはこれが限界かと思わせるところが要所要所に見受けられます。

今回のスクリプト作成に当たっては下記のサイトを参考にさせていただきました。特にINIファイルの処理ルーチンは非常に参考になりました。ありがとうございます!
何時から何時まではスリープにしたいときの設定です。何時からのからの部分を設定します。

・ ini ファイルの処理
http://winofsql.jp/VA003334/vbsguide060101070259.htm

・ VBScript で四捨五入する (unibon)
http://www.geocities.co.jp/SiliconValley/4334/unibon/asp/round.html

・ VBScriptVBScriptで日付用のFormat関数を作成するサンプルプログラム
http://billyboy.blog81.fc2.com/blog-entry-173.html

以下スクリプト本体。

———-

.INI

[SettingTimes]
UseMinutes=3
IntervalMinutes=3
SleepStartTime=4:00:00
SleepEndTime=18:00:00
SaveDateTime=2009/09/18 4:40:27

———-

.VBS


” VbScript
” ShutDownTimer.vbs
” URL: http://www.lowvism.com
” シャットダウンタイマ
” 指定した時間にシャットダウンする。
” 一定時間より短い再起動時間では強制シャットダウンする。
” スリープ時間帯をもうけてこの時間帯であれば強制シャットダウンする。

‘ このスクリプトの名前
Const AppName = “ShutDown Timer”

‘ 適当に起動待ち
‘ (Windowsの起動タイミングとの関係)
‘ スタートアップに入れる場合はなるべく下記のコメントを消す
‘Wscript.sleep(1*60*1000)

‘ シェルオブジェクトのセット
Set WSHShell = Wscript.CreateObject(“Wscript.Shell”)

‘ メインルーチンの呼び出し
Call VbsMain()

‘ メインルーチン
Sub VbsMain

‘ 設定ファイル名
Const fName = “ShutDownTimer.ini”
‘ 設定ファイルの有無を確認
If Not GetFileExists(fName) Then
WSHShell.Popup “設定ファイル ” & fName & ” が見つかりませんでした”, _
10, AppName, vbInformation
WScript.Quit
End If

Dim MinOfIntervalTime, SecOfIntervalTime
MinOfIntervalTime = GetProfileString( fName, “SettingTimes”, “IntervalMinutes”)
SecOfIntervalTime = MinOfIntervalTime * 60

Dim MinOfUseTime, SecOfUseTime
MinOfUseTime = _
GetProfileString( fName, “SettingTimes”, “UseMinutes”)
SecOfUseTime = MinOfUseTime * 60

Dim SaveDT, PassDT
SaveDT = _
GetProfileString( fName, “SettingTimes”, “SaveDateTime”)
PassDT = (DateDiff(“s”, SaveDT, Now))

If IsEmpty(MinOfIntervalTime) Then
WSHShell.Popup _
“設定ファイル ” & fName & ” が不正です。” & vbCrLf & _
“設定箇所 ” & “MinutesOfIntervalTime” & ” です。”, _
10, AppName, vbInformation
WScript.Quit
End If

If IsEmpty(MinOfIntervalTime) Then
WSHShell.Popup _
“設定ファイル ” & fName & ” が不正です。” & vbCrLf & _
“設定箇所 ” & “MinutesOfUseTime” & ” です。”, _
10, AppName, vbInformation
WScript.Quit
End If

If IsEmpty(SaveDT) Then
WSHShell.Popup _
“設定ファイル ” & fName & ” が不正です。” & vbCrLf & _
“設定箇所 ” & “SaveDateTime” & ” です。”, _
10, AppName, vbInformation
WScript.Quit
End If

‘ スリープ時間帯なら寝る
Call SleepyMe(fName)

‘ 設定時間に対して経過時間が短ければシャットダウン
If SecOfIntervalTime > SecOfUseTime Then
WSHShell.Popup _
“現在日時は ” & Now() & ” です” & vbCrLf & _
“前回終了時日時は ” & SaveDT & ” です” & vbCrLf & _
“設定時間は ” & SecondsToMinutes(SecOfIntervalTime) & ” です” & vbCrLf & _
“要求を満たしてないのでシャットダウンします”, _
10, AppName, vbInformation
Call RunShutdown
WScript.Quit
End If

WSHShell.Popup _
“今から ” & MinutesOfUseTime & “分間までパソコン使えます。”, _
10, AppName, vbInformation

WaitTickCOunt(PassDT)

WSHShell.Popup _
“時間なりました。1分後にシャットダウンします。” & vbCrLf & _
MinOfIntervalTime & “分後に使えるようになります。”, _
60, AppName, vbInformation
Call WriteProfileString( fName, “SettingTimes”, “SaveDateTime”, Now() )

‘ シャットダウンコール
Call RunShutdown()

‘Call MsgBox(“Round = ” & Round(x, 0) & “, MyRound = ” & MyRound(x, 0))

WScript.Quit

End Sub

Sub SleepyMe(fName)

Dim t, sSleep, eSleep

t = Time()

‘ 時間の比較
sSleep = GetProfileString( fName, “SettingTimes”, “SleepStartTime”)
eSleep = GetProfileString( fName, “SettingTimes”, “SleepEndTime”)

If IsEmpty(sSleep) Then
WSHShell.Popup _
“設定ファイル ” & fName & ” が不正です。” & vbCrLf & _
“設定箇所 ” & “SleepStartTime” & ” です。”, _
10, AppName, vbInformation
WScript.Quit
End If

If IsEmpty(eSleep) Then
WSHShell.Popup _
“設定ファイル ” & fName & ” が不正です。” & vbCrLf & _
“設定箇所 ” & “SleepEndTime” & ” です。”, _
10, AppName, vbInformation
WScript.Quit
End If

‘ TimeValue() を使用して文字列からバリアントへ変換と比較
If TimeValue(sSleep) < t And t < TimeValue(eSleep) Then WSHShell.Popup _ sSleep & " から " & eSleep & "はスリープ時間帯です。" & vbCrLf & _ "現在時刻は " & t & " です。" & _ "ただちに終了します。", _ 10, AppName, vbInformation WScript.Quit End If Call RunShutdown() End Sub Sub WaitTickCount(sec) Dim TickCount TickCOunt = sec * 1000 Wscript.sleep(TickCount) End Sub Sub RunShutdown() Set objSystemSet = GetObject("winmgmts:{impersonationLevel=impersonate,(Shutdown)}").InstancesOf("Win32_OperatingSystem") For Each objSystem In objSystemSet objSystem.Win32Shutdown 8 Next End Sub ' *********************************************************** ' 分から秒へ変換して返す ' *********************************************************** Function SecondsToMinutes (sec) Dim dd , hh, mm mm = sec 60: ss = tt Mod 60 hh = mm 60: mm = mm Mod 60 dd = hh 24: hh = hh Mod 24 SecondsToMinutes = dd & "日" & hh & "時間" & mm & "分" & ss & "秒" End Function ' *********************************************************** ' 設定ファイルの有無を確認する関数 ' *********************************************************** Function GetFileExists(fName) Set fso = WScript.CreateObject("Scripting.FileSystemObject") GetFileExists = fso.FileExists(fName) End Function ' *********************************************************** ' 読み出し ( 無ければ Empty を返す ) ' *********************************************************** Function GetProfileString( strPath, strSection, strEntry ) Dim objHandle,aData,bFound,strWork,aWork,I Set fso = WScript.CreateObject("Scripting.FileSystemObject") Set objHandle = Fso.OpenTextFile( strPath, 1 ) aData = Split( objHandle.ReadAll, vbCrLf ) objHandle.Close GetProfileString = Empty bFound = False For I = 0 to Ubound( aData )-1 if bFound then if Left( aData( I ), 1 ) = "[" then Exit For End If strWork = LTrim( aData( I ) ) if Left( strWork, Len(strEntry)) = strEntry then aWork = Split( strWork, "=" ) if Trim(aWork(0)) = strEntry then if Ubound( aWork ) = 1 then GetProfileString = Trim( aWork( 1 ) ) Exit For End If End If End If End If if aData(I) = "[" & strSection & "]" then bFound = True End If Next End Function ' *********************************************************** ' 書き込み ' *********************************************************** Function WriteProfileString( strPath, strSection, strEntry, strValue ) Dim objHandle,aData,bFound,strWork,aWork,I,nSection,bReplace Set fso = WScript.CreateObject("Scripting.FileSystemObject") Set objHandle = Fso.OpenTextFile( strPath, 1 ) aData = Split( objHandle.ReadAll, vbCrLf ) objHandle.Close bReplace = False bFound = False For I = 0 to Ubound( aData )-1 if bFound then if Left( aData( I ), 1 ) = "[" then Exit For End If strWork = LTrim( aData( I ) ) if Left( strWork, Len(strEntry)) = strEntry then aWork = Split( strWork, "=" ) if Trim(aWork(0)) = strEntry then if Ubound( aWork ) = 1 then strWork = Trim( aWork( 1 ) ) aData( I ) = Replace( aData( I ), strWork, strValue ) strWork = Join( aData, vbCrLf ) Set objHandle = Fso.OpenTextFile( strPath, 2, True ) objHandle.Write strWork objHandle.Close bReplace = True Exit For End If End If End If End If if aData(I) = "[" & strSection & "]" then nSection = I bFound = True End If Next if not bReplace then ' セクションはあったが、エントリは無かった if bFound then aData(nSection) = aData(nSection) & _ vbCrLf & strEntry & "=" & strValue strWork = Join( aData, vbCrLf ) Set objHandle = Fso.OpenTextFile( strPath, 2, True ) objHandle.Write strWork objHandle.Close Else ' セクションも、エントリも無かった aData(Ubound( aData )-1) = aData(Ubound( aData )-1) & _ vbCrLf & "[" & strSection & "]" & _ vbCrLf & strEntry & "=" & strValue strWork = Join( aData, vbCrLf ) Set objHandle = Fso.OpenTextFile( strPath, 2, True ) objHandle.Write strWork objHandle.Close End If End If End Function ' *********************************************************** ' 四捨五入を返す関数 ' *********************************************************** Function MyRound(ByVal a, ByVal b) Dim k Dim x If b >= 0 Then
k = CLng(10 ^ b)
x = Int(a * k + 0.5) / k
MyRound = x
Else
k = CLng(10 ^ (-b))
x = Int(a / k + 0.5) * k
MyRound = x
End If

End Function

‘ ***********************************************************
‘ 日付書式を設定して返す関数
‘ ***********************************************************
Function Format(data,f,separator)

Select Case f
Case “yyyymmdd”
y = year(data)
If month (data) < 10 Then m = "0" & cstr(month(data)) Else m = month(data) End If If day (data) < 10 Then d = "0" & cstr(day(data)) Else d = day(data) End If ret = y & separator & m & separator & d Case "yymmdd" y = right(year(data),2) If month (data) < 10 Then m = "0" & cstr(month(data)) Else m = month(data) End If If day (data) < 10 Then d = "0" & cstr(day(data)) Else d = day(data) End If ret = y & separator & m & separator & d Case "年月日" ret = year(data) & "年" & month(data) & "月" & day(data) & "日" Case "yyyymmdd年月日" y = year(data) If month (data) < 10 then m = "0" & cstr(month(data)) Else m = month(data) End If If day (data) < 10 Then d = "0" & cstr(day(data)) Else d = day(data) End If ret = y & "年" & m & "月" & d & "日" Case "和暦" If data <= DateSerial(1912, 7, 29) Then y = "明治" & Year(data) - 1867 ElseIf data >= DateSerial(1912, 7, 30) And data <= DateSerial(1926, 12, 24) Then y = "大正" & Year(data) - 1911 ElseIf data >= DateSerial(1926, 12, 25) And data <= DateSerial(1989, 1, 7) Then y = "昭和" & Year(data) - 1925 ElseIf data >= DateSerial(1989, 1, 8) Then
y = “平成” & Year(data) – 1988
End If

ret = y & “年” & month(data) & “月” & day(data) & “日”

Case Else
ret = data
End Select

format = ret

End Function