前回は 指定された時間にPCをロックするタスクを準備する仕組みをつくるところまで進めました。
今回は、第１回で準備したVBSファイルへ、前回までに準備した休憩時間以外のときの処理を呼び出す記述を追記し、完成させます。
目次：
次の休憩時間を取得する
第２回～前回までに準備した仕組みには次の休憩時間の開始時刻の情報が必要です。
Outlookの予定を確認する関数を第一回で作りました。これを利用して次の休憩の開始時刻を取得します。
ここで取得した時刻データを前回準備したVBSファイルに渡し、タスクの実行時間を更新します。
ただ、Outlookの時間データの書式と、タスクの時間データの書式が違うため、変換が必要になります。
Outlookの時間データの書式
yyyy/MM/dd hh:mm:ss
タスクの時間データの書式
yyyy-MM-ddThh:mm:ss
時間データの書式の変換はReplace関数を使用して行ないます。
次の休憩時間を取得するコード
実装：scdlCheckBreakTimeSchedule.vbs
'--------------------------------------------------------------------------------
'現在時刻以降の休憩を探す
'--------------------------------------------------------------------------------
Public Function getNextBreakTime(Byval addNValue)
getNextBreakTime = ""
Dim colAppts
' 今日の予定を取得する
Dim todayAppts
Set todayAppts = getTodaySchedule(colAppts,"")
Do While Not todayAppts Is Nothing
' 現在進行中の予定を探します
If todayAppts.Start >= Now And rePattern1.Test(todayAppts.Categories) Or todayAppts.Start >= Now And rePattern2.Test(todayAppts.Categories) Then
' 取得した日時データをyyyy-MM-ddThh:mm:ss形式で返します
getNextBreakTime = Replace(Replace(DateAdd("n", addNValue, todayAppts.Start),"/","-")," ","T")
Exit Do
End If
Set todayAppts = colAppts.FindNext
Loop
End Function
引数について
- addNValue
タスクの実行時間を調整する場合に、分数を指定します。
タスク開始時間を渡し、タスク作成を依頼する
取得したデータを引数に、前回準備したVBSファイルを呼び出します。
タスク作成を依頼するコード
実装：scdlCheckBreakTimeSchedule.vbs
' 次の休憩時間を指定してタスクを登録 Dim nextBreakTime nextBreakTime = getNextBreakTime(0) objWsh.Run "scdlSetBreakTimeSchedule.vbs nextBreakTime",0
Outlookの予定を確認し、休憩時間になったらパソコンをロックするコード全文
第１回の処理と合わせて「scdlCheckBreakTimeSchedule.vbs」のコードは下記になります。
Option Explicit
'オブジェクトを生成
Dim objWsh
Set objWsh = WScript.CreateObject("WScript.Shell")
' カテゴリ確認用の正規表現を準備
Dim rePattern1,rePattern2
Set rePattern1 = CreateObject("VBScript.RegExp")
Set rePattern2 = CreateObject("VBScript.RegExp")
rePattern1.Pattern = "^.*4-.*$"
rePattern2.Pattern = "^.*9-.*$"
' 休憩中かを確認
if check_DuringBreakTime <> 0 Then
' 休憩中の場合はロックアウトを実行して終了
objWsh.Run "sysLockWorkStation.vbs 0",0
WScript.Quit()
End if
' 次の休憩時間を指定してタスクを登録
Dim nextBreakTime
nextBreakTime = getNextBreakTime(0)
objWsh.Run "scdlSetBreakTimeSchedule.vbs nextBreakTime",0
' --------------------------------------------------------------------------------
' 現在の予定が休憩(4-)・睡眠(9-)であるかを確認する
' 休憩=4 睡眠=9を返す。それ以外の場合は0を返す
' --------------------------------------------------------------------------------
Function check_DuringBreakTime()
check_DuringBreakTime = 0
Dim colAppts
' 今日の予定を取得する
Dim todayAppts
Set todayAppts = getTodaySchedule(colAppts,"")
Do While Not todayAppts Is Nothing
' 現在進行中の予定を探します
If todayAppts.Start <= Now And todayAppts.End >= Now Then
if rePattern1.test(todayAppts.Categories) Then
check_DuringBreakTime = 4
Elseif rePattern2.test(todayAppts.Categories) Then
check_DuringBreakTime = 9
Else
Exit Do
End if
End If
Set todayAppts = colAppts.FindNext
Loop
End Function
'--------------------------------------------------------------------------------
'現在時刻以降の休憩(4-)・睡眠(9-)を探す
'--------------------------------------------------------------------------------
Public Function getNextBreakTime(Byval addNValue)
getNextBreakTime = ""
Dim colAppts
' 今日の予定を取得する
Dim todayAppts
Set todayAppts = getTodaySchedule(colAppts,"")
Do While Not todayAppts Is Nothing
' 現在進行中の予定を探します
If todayAppts.Start >= Now And rePattern1.Test(todayAppts.Categories) Or todayAppts.Start >= Now And rePattern2.Test(todayAppts.Categories) Then
' 取得した日時データをyyyy-MM-ddThh:mm:ss形式で返します
getNextBreakTime = Replace(Replace(DateAdd("n", addNValue, todayAppts.Start),"/","-")," ","T")
Exit Do
End If
Set todayAppts = colAppts.FindNext
Loop
End Function
' 今日の予定一覧を取得します
Function getTodaySchedule(ByRef colAppts,Byval addCase)
' Outlookオブジェクト格納用
Dim oApp
Set oApp = CreateObject("Outlook.Application")
Dim myNameSpace
Set myNameSpace = oApp.GetNamespace("MAPI")
'範囲を考える
Dim STDATE
Dim ENDATE
STDATE = Date
ENDATE = DateAdd("d", 1, STDATE)
' 9=規定のフォルダを取得
Set colAppts = myNameSpace.GetDefaultFolder(9).Items
colAppts.Sort "[Start]"
colAppts.IncludeRecurrences = True '定期的な予定があってもこの行で取得可能！
' 今日の予定を取得する
Set getTodaySchedule = colAppts.Find("[Start] >= '" & STDATE & "' AND [Start] < '" & ENDATE & "'" & addCase)
End Function
' 指定プロセスの起動を確認します
Function checkProcessExec(byval processName)
Dim Service,QfeSet
Set Service = CreateObject("WbemScripting.SWbemLocator").ConnectServer
Set QfeSet = Service.ExecQuery("Select * From Win32_Process Where Caption='" & processName & "'")
checkProcessExec = QfeSet.Count > 0
End Function
今回はここまで。次回に続きます。
今回の仕組み必要なステップは下記になります。
