Тема: HTA, VBS: Родительский контроль для XP
Намедни ко мне обратился товарищ с просьбой помочь ограничить время, которое его ребенок проводит за компьютером.
Родительский контроль не в счет - у него XP, кроме того было необходимо не задавать часы использования, а контролировать время в совокупности за день.
В итоге получилось вот такое HTA:
<html>
<head>
<title>TR</title>
<meta http-equiv=content-type content="text-html; charset=windows-1251">
<meta http-equiv=MSThemeCompatible content=yes>
<hta:application
icon=keymgr.dll
scroll=no
maximizebutton=no
version="1.0"
>
</head>
<style type="text/css">
#btn{width:100px;}
#min{width:35px;}
</style>
<script language="VBScript">
Const ClassName = "MySuperClass"
Const TimerId = "MySuperTimer"
Const ConsumerTimer = "MySuperConsumer"
Const FilterTimer = "MySuperFilter"
Sub window_onload()
window.resizeTo 230, 90
window.moveTo 20, 20
window.setTimeout "afterLoad",10, "vbscript"
End Sub
Sub afterLoad()
Const MinutePermited = "MinutePermited"
Set objDefault = GetObject("winmgmts:\\.\root\default")
If ClassExists(objDefault) Then
min.Value = objDefault.Get(ClassName).Properties_(MinutePermited) 'читаем значение свойства
Set objSubscription = GetObject("winmgmts:\\.\root\subscription")
If SubscriptionExists(objSubscription) Then
btn.Value = "Удалить"
Else
btn.Value = "Установить"
End If
Set objSubscription = Nothing
Else
btn.Value = "Установить"
End If
Set objDefault = Nothing
End Sub
Sub btn_onclick()
Set objSubscription = GetObject("winmgmts:\\.\root\subscription")
If Me.Value = "Установить" Then
If min.Value = vbNullString Or Not IsNumeric(min.Value) Then
MsgBox "Введите количество минут"
Else
If InstallTR Then Me.Value = "Удалить"
End If
Else
If DeleteTR Then
Me.Value = "Установить"
min.Value = ""
End If
End If
Set objSubscription = Nothing
End Sub
Function InstallTR()
On Error Resume Next
Set objDefault = GetObject("winmgmts:\\.\root\default")
If ClassCreate(objDefault) Then
Set objSubscription = GetObject("winmgmts:\\.\root\subscription")
If ScriptConsumerExists(objSubscription) Then
If SubscriptionCreate(objSubscription) Then InstallTR = True
End If
Set objSubscription = Nothing
End If
Set objDefault = Nothing
End Function
Function DeleteTR()
On Error Resume Next
Set objSubscription = GetObject("winmgmts:\\.\root\subscription")
If SubscriptionDelete(objSubscription) Then
Set objDefault = GetObject("winmgmts:\\.\root\default")
If ClassDelete(objDefault) Then DeleteTR = True
Set objDefault = Nothing
End If
Set objSubscription = Nothing
End Function
'***** Класс *****
'наличие класса
Function ClassExists(objDefault)
On Error Resume Next
For Each objClass In objDefault.SubclassesOf()
If InStr(objClass.Path_.Path, ClassName) Then
ClassExists = True
Exit Function
End If
Next
End Function
'создаем класс
Function ClassCreate(objDefault)
On Error Resume Next
Const Created = "Created" 'дата создания
Const LastBootUpDate = "LastBootUpDate" 'дата последней загрузки
Const MinuteCount = "MinuteCounter" 'счетчик отработанных минут
Const MinutePermited = "MinutePermited" 'количество разрешенных минут
With objDefault.Get()
.Path_.Class = ClassName
'добавляем свойства
.Properties_.Add Created, 101
.Properties_.Add LastBootUpDate, 101
.Properties_.Add MinuteCount, 19
.Properties_.Add MinutePermited, 19
'значения свойств
Set dateTime = CreateObject("WbemScripting.SWbemDateTime")
dateTime.SetVarDate Now(),True
.Properties_(Created) = dateTime.Value
.Properties_(LastBootUpDate) = dateTime.Value
.Properties_(MinuteCount) = 0
.Properties_(MinutePermited) = min.Value
'пишем класс в репозиторий
.Put_
End With
If Err.Number = 0 Then
ClassCreate = True
End If
End Function
'удаляем класс
Function ClassDelete(objDefault)
On Error Resume Next
With objDefault.Get()
.Path_.Class = ClassName
.Put_
End With
objDefault.Delete ClassName
If Err.Number = 0 Then
ClassDelete = True
End If
End Function
'********************
'***** Подписка *****
'проверка регистрации ActiveScriptEventConsumer
Function ScriptConsumerExists(objSubscription)
On Error Resume Next
If objSubscription.ExecQuery( _
"SELECT * FROM __Provider WHERE Name='ActiveScriptEventConsumer'").Count Then
ScriptConsumerExists = True
End If
End Function
'наличие подписки
Function SubscriptionExists(objSubscription)
On Error Resume Next
If objSubscription.ExecQuery("SELECT * FROM ActiveScriptEventConsumer WHERE Name = '" & ConsumerTimer & "'").Count Then
SubscriptionExists = True
End If
End Function
'создаем подписку
Function SubscriptionCreate(objSubscription)
On Error Resume Next
Dim sTime
sTime = 60000 'миллисекунд для таймера
'создание таймера и его конфигурирование
With objSubscription.Get("__IntervalTimerInstruction").SpawnInstance_()
.TimerId = TimerId
.IntervalBetweenEvents = sTime 'миллисекунд
.SkipIfPassed = True 'пропустить, если событие прошло
.Put_
End With
'создание фильтра таймера
With objSubscription.Get("__EventFilter").SpawnInstance_()
.Name = FilterTimer
.QueryLanguage = "WQL"
.Query = "SELECT * FROM __TimerEvent WHERE TimerId = '" & TimerId & "'"
Set objFilterPath = .Put_()
End With
'собираем текст скрипта
varrr = "On Error Resume Next" & vbCrLf & "Const ClassName = ""MySuperClass""" & vbCrLf & "Const LastBootUpDate = ""LastBootUpDate""" & vbCrLf & "Const MinuteCount = ""MinuteCounter""" & vbCrLf & "Const MinutePermited = ""MinutePermited""" & vbCrLf & "Set objDefault = GetObject(""winmgmts:\\.\root\default:"" & ClassName)" & vbCrLf & "If ClassExists(objDefault) Then" & vbCrLf & "Set dateTime = CreateObject(""WbemScripting.SWbemDateTime"")" & vbCrLf & "dateTime.Value = objDefault.Properties_(LastBootUpDate)" & vbCrLf & "If DateValue(dateTime.GetVarDate()) <> Date() Then" & vbCrLf
varrr = varrr & "dateTime.SetVarDate Now(),True" & vbCrLf & "With objDefault" & vbCrLf & ".Properties_(LastBootUpDate) = dateTime.Value" & vbCrLf & ".Properties_(MinuteCount) = 0" & vbCrLf & ".Put_" & vbCrLf & "End With" & vbCrLf & "End If" & vbCrLf & "With objDefault" & vbCrLf & ".Properties_(MinuteCount) = .Properties_(MinuteCount) + 1" & vbCrLf & ".Put_ " & vbCrLf & "If .Properties_(MinuteCount) >= .Properties_(MinutePermited) Then Shutdown" & vbCrLf
varrr = varrr & "End With" & vbCrLf & "End If" & vbCrLf & "Function ClassExists(objDefault)" & vbCrLf & "On Error Resume Next" & vbCrLf & "For Each objClass In objDefault.SubclassesOf()" & vbCrLf & "If InStr(objClass.Path_.Path, ClassName) Then" & vbCrLf & "ClassExists = True" & vbCrLf & "Exit Function" & vbCrLf & "End If" & vbCrLf & "Next" & vbCrLf & "End Function" & vbCrLf
varrr = varrr & "Sub Shutdown()" & vbCrLf & "On Error Resume Next" & vbCrLf & "For Each obj In GetObject(""winmgmts:{impersonationLevel=impersonate,(Shutdown)}!\\.\root\cimv2"").ExecQuery(""SELECT * FROM Win32_OperatingSystem"")" & vbCrLf & "obj.Win32Shutdown(12)" & vbCrLf & "Next" & vbCrLf & "End Sub"
'создание потребителя события таймера
With objSubscription.Get("ActiveScriptEventConsumer").SpawnInstance_()
.Name = ConsumerTimer
.ScriptingEngine = "VBScript"
.KillTimeout = 10 'завершить выполнение через 10 секунд
'.ScriptFileName = "C:\temp\Go.vbs" 'для проверки
.ScriptText = varrr
Set objConsumerPath = .Put_()
End With
'связка фильтра и потребителя
With objSubscription.Get("__FilterToConsumerBinding").SpawnInstance_()
.Filter = objFilterPath
.Consumer = objConsumerPath
.Put_
End With
If Err.Number = 0 Then
SubscriptionCreate = True
End If
End Function
'удаляем подписку
Function SubscriptionDelete(objSubscription)
On Error Resume Next
'удаляем фильтр таймера
Set colFilters = objSubscription.ExecQuery("SELECT * FROM __EventFilter WHERE Name='" & FilterTimer & "'")
If colFilters.Count Then
For Each objFilter In colFilters
objFilter.Delete_
Next
End If
Set colFilters = Nothing
'удаляем потребителя таймера
Set colConsumers = objSubscription.ExecQuery("SELECT * FROM ActiveScriptEventConsumer WHERE Name='" & ConsumerTimer & "'")
If colConsumers.Count Then
For Each objConsumer In colConsumers
objConsumer.Delete_
Next
End If
Set colConsumers = Nothing
Set colTimers = objSubscription.ExecQuery("SELECT * FROM __IntervalTimerInstruction WHERE TimerId='" & TimerId & "'")
If colTimers.Count Then
For Each objTimer In colTimers
objTimer.Delete_
Next
End If
Set colTimers = Nothing
If Err.Number = 0 Then
SubscriptionDelete = True
End If
End Function
'********************
</script>
<body>
<input id="btn" type="button"/> <input id="min" type="text"/> минут
</body>
</html>Папам и мамам посвящается... 
?
