'Версия 1.4
'
'
'Изменения:
'1.1 - добавлено отключение автозапуска всех дисков, введено кэширование файла настроек, другие мелкие фиксы
'1.2 - добавлено отключение сервиса съёмных устройств (читай пофиксена дырка)
'1.3 - ведение и отсылка лога изменений
'1.4 - добавлено отключение автозапуска "Autorun.inf"
'
'
'Автор: Петрунин Алексей. 23.03.09
'Закрытие портов ЮСБ, флоппи и т.п.
Option Explicit
on error resume next
Dim objNetwork, WshShell, szIniFileName, FSO, szMessageToSend, szLogFileName, nMaxLogSize
Dim szLastIniFileName, szLastIniData, szMailSender, szMailTo, szMailServer
Set objNetwork = CreateObject("WScript.Network")
Set WshShell = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
szLogFileName = WshShell.ExpandEnvironmentStrings("%WinDir%") & "\" & "port_auditor.log"
szIniFileName = FSO.GetParentFolderName(WScript.ScriptFullName) & "\" & Left(WScript.ScriptName, Len(WScript.ScriptName) - 4) & ".ini"
if GetProfileString("General", "MaxLogSize", szIniFileName)="" then
nMaxLogSize=512000
else
nMaxLogSize = CLng(GetProfileString("Options", "MaxLogSize", szIniFileName))
end if
szMailServer=GetProfileString("Options", "MailServer", szIniFileName)
szMailSender=GetProfileString("Options", "MailSender", szIniFileName)
szMailTo=GetProfileString("options", "MailTo", szIniFileName)
If InStr(1,GetProfileString("General", "MASS_STORAGE", szIniFileName), objNetwork.ComputerName,vbTextCompare) > 0 Then
EnableDisableServiceNtmsSvc "Automatic"
if WshShell.RegRead ("HKLM\SYSTEM\CurrentControlSet\Services\USBSTOR\Start")<>3 then
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\USBSTOR\Start", 3, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Открыт USB-Flash disks"
end if
Else
EnableDisableServiceNtmsSvc "Disabled"
if WshShell.RegRead ("HKLM\SYSTEM\CurrentControlSet\Services\USBSTOR\Start")<>4 then
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\USBSTOR\Start", 4, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Закрыт USB-Flash disks"
end if
End If
If InStr(1,GetProfileString("General", "CDROM", szIniFileName), objNetwork.ComputerName, vbTextCompare) > 0 Then
if WshShell.RegRead ("HKLM\SYSTEM\CurrentControlSet\Services\Cdrom\Start")<>1 then
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\Cdrom\Start", 1, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Открыт CD-ROM"
end if
Else
if WshShell.RegRead ("HKLM\SYSTEM\CurrentControlSet\Services\Cdrom\Start")<>4 then
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\Cdrom\Start", 4, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Закрыт CD-ROM"
end if
End If
If InStr(1,GetProfileString("General", "Floppy", szIniFileName), objNetwork.ComputerName, vbTextCompare) > 0 Then
if WshShell.RegRead ("HKLM\SYSTEM\CurrentControlSet\Services\Flpydisk\Start")<>3 or WshShell.RegRead ("HKLM\SYSTEM\CurrentControlSet\Services\Sfloppy\Start")<>3 then
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\Flpydisk\Start", 3, "REG_DWORD"
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\Sfloppy\Start", 3, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Открыт флоппи-дисковод"
end if
Else
if WshShell.RegRead ("HKLM\SYSTEM\CurrentControlSet\Services\Flpydisk\Start")<>4 or WshShell.RegRead ("HKLM\SYSTEM\CurrentControlSet\Services\Sfloppy\Start")<>4 then
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\Flpydisk\Start", 4, "REG_DWORD"
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\Sfloppy\Start", 4, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Закрыт флоппи-дисковод"
end if
End If
WshShell.RegRead "HKLM\SYSTEM\CurrentControlSet\Services\Flpydisk\WriteProtect"
if err.number then 'нет ветки реестра
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\Flpydisk\"
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\Flpydisk\WriteProtect", 1, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Запрещена запись на сменные флоппи носители - создан раздел реестра"
err.clear
end if
If InStr(1,GetProfileString("General", "FLOPPY_WRITE_ENABLED", szIniFileName), objNetwork.ComputerName, vbTextCompare) > 0 Then
if WshShell.RegRead ("HKLM\SYSTEM\CurrentControlSet\Services\Flpydisk\WriteProtect")<>0 then
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\Flpydisk\WriteProtect", 0, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Разрешена запись на сменные флоппи носители"
end if
Else
if WshShell.RegRead ("HKLM\SYSTEM\CurrentControlSet\Services\Flpydisk\WriteProtect")<>1 then
WshShell.RegWrite "HKLM\SYSTEM\CurrentControlSet\Services\Flpydisk\WriteProtect", 1, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Запрещена запись на сменные флоппи носители"
end if
End If
WshShell.RegRead "HKLM\System\CurrentControlSet\Control\StorageDevicePolicies\WriteProtect"
if err.number then 'нет ветки реестра
WshShell.RegWrite "HKLM\System\CurrentControlSet\Control\StorageDevicePolicies\"
WshShell.RegWrite "HKLM\System\CurrentControlSet\Control\StorageDevicePolicies\WriteProtect", 1, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Запрещена запись на сменные USB носители - создан раздел реестра"
err.clear
end if
If InStr(1,GetProfileString("General", "MASS_STORAGE_WRITE_ENABLED", szIniFileName), objNetwork.ComputerName, vbTextCompare) > 0 Then
if WshShell.RegRead ("HKLM\System\CurrentControlSet\Control\StorageDevicePolicies\WriteProtect")<>0 then
WshShell.RegWrite "HKLM\System\CurrentControlSet\Control\StorageDevicePolicies\WriteProtect", 0, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Разрешена запись на сменные USB носители"
end if
Else
if WshShell.RegRead ("HKLM\System\CurrentControlSet\Control\StorageDevicePolicies\WriteProtect")<>1 then
WshShell.RegWrite "HKLM\System\CurrentControlSet\Control\StorageDevicePolicies\WriteProtect", 1, "REG_DWORD"
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Запрещена запись на сменные USB носители"
end if
End If
dim bAutorunSettingChanged
'отключаем автозапуск всех дисков
WshShell.RegRead "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoDriveTypeAutoRun"
if WshShell.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoDriveTypeAutoRun")<>255 or err.number>0 then
bAutorunSettingChanged=true
WshShell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\"
WshShell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoDriveTypeAutoRun", 255, "REG_DWORD"
if err.number > 0 then
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "На ПК отключён автозапуск всех носителей - создан раздел реестра"
else
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "На ПК отключён автозапуск всех носителей - раздел реестра уже существовал"
end if
err.clear
end if
WshShell.RegRead "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\AutoplayHandlers\CancelAutoplay\Files\*.*"
if WshShell.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\AutoplayHandlers\CancelAutoplay\Files\*.*")<>"" or err.number>0 then
bAutorunSettingChanged=true
WshShell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\AutoplayHandlers\CancelAutoplay\Files\*.*", "", "REG_SZ"
if err.number > 0 then
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "На ПК отключён автозапуск всех типов файлов - создан раздел реестра"
else
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "На ПК отключён автозапуск всех типов файлов - раздел реестра уже существовал"
end if
err.clear
end if
WshShell.RegRead "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\Autorun.inf\"
if WshShell.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\Autorun.inf\")<>"@SYS:DoesNotExist" or err.number>0 then
bAutorunSettingChanged=true
WshShell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\"
WshShell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\IniFileMapping\Autorun.inf\", "@SYS:DoesNotExist"
if err.number > 0 then
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "На ПК отключён автозапуск Autorun.inf - создан раздел реестра"
else
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "На ПК отключён автозапуск Autorun.inf - раздел реестра уже существовал"
end if
err.clear
end if
if bAutorunSettingChanged then
WshShell.Run ".\updates\WindowsXP-KB967715-x86-RUS.exe /passive /norestart", 1, true
WshShell.Run ".\updates\Windows2000-KB967715-x86-RUS.EXE /passive /norestart", 1, true
WshShell.Run ".\updates\WindowsServer2003-KB967715-x86-RUS.exe /passive /norestart", 1, true
WshShell.Run ".\updates\WindowsServer2003-KB967715-x86-ENU.exe /passive /norestart", 1, true
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Установлено обновление KB967715"
end if
if szMessageToSend <> "" then SendMail szMessageToSend
WScript.Quit
Sub EnableDisableServiceNtmsSvc(state_to_set)
'Boot
'System
'Automatic
'Manual
'Disabled
dim strComputer, objWMIService, objShare, objInParam, objOutParams
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set objShare = objWMIService.Get("Win32_Service.Name='NtmsSvc'")
if lcase(objShare.StartMode) = lcase(state_to_set) or lcase(objShare.StartMode& "matic") = lcase(state_to_set ) then exit sub
Set objInParam = objShare.Methods_("ChangeStartMode").inParameters.SpawnInstance_()
objInParam.Properties_.Item("StartMode") = state_to_set
Set objOutParams = objWMIService.ExecMethod("Win32_Service.Name='NtmsSvc'", "ChangeStartMode", objInParam)
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
Set objShare = objWMIService.Get("Win32_Service.Name='NtmsSvc'")
szMessageToSend = szMessageToSend & vbcrlf & vbtab & "Сервис NtmsSvc переведён в состояние " & chr(34) & state_to_set & chr(34) & vbcrlf & vbtab & vbtab & "Проверка установленного состояния сервиса показала статус запуска " & chr(34) & objShare.StartMode & chr(34)
end sub
Sub SendMail(MsgText)
On Error Resume Next
WriteToLog MsgText
if szMailServer="" or szMailSender="" or szMailTo="" then exit sub
Dim objEmail
Set objEmail = CreateObject("CDO.Message")
objEmail.From = szMailSender
objEmail.to = szMailTo
objEmail.Subject = objNetwork.ComputerName + " изменения доступа к портам ПК"
objEmail.Textbody = "Письмо отправлено из " & chr(34) & WScript.ScriptFullName & chr(34) & vbCrLf & vbCrLf & vbCrLf & MsgText
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = szMailServer
objEmail.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
if FSO.FileExists(szLogFileName) then
objEmail.Textbody=objEmail.Textbody & vbcrlf & vbcrlf & "Во вложении лог операций на данном ПК."
objEmail.AddAttachment szLogFileName
end if
objEmail.Configuration.Fields.Update
objEmail.Send
End Sub
Function GetProfileString(section,key,filename)
if fso.FileExists(filename) then
if szLastIniFileName<>lcase(filename) & vbtab & FSO.GetFile(filename).DateLastModified then
szLastIniFileName=lcase(filename) & vbtab & FSO.GetFile(filename).DateLastModified
szLastIniData=""
if FSO.GetFile(filename).Size>0 then
szLastIniData=split(FSO.OpenTextFile(filename).ReadAll & vbcrlf,vbcrlf)
end if
end if
Dim readini,bsection, i
bsection=False
Set readini = fso.OpenTextFile(filename,1)
for i=0 to ubound(szLastIniData)-1
Dim trimstrini
trimstrini = MyTrim(szLastIniData(i))
if Left(trimstrini,1)="[" and Right(Trimstrini,1)="]" then
if StrComp(Trimstrini,"[" & MyTrim(section) & "]",1)=0 Then
bsection=True
else
bsection =False
end if
Else
if bsection then
Dim poskey
poskey = InStrRev(Trimstrini,"=")
if posKey>0 then
if StrComp(MyTrim(Left(Trimstrini,poskey-1)),MyTrim(key),1)=0 Then
GetProfileString = MyTrim(Mid(Trimstrini,poskey+1))
Exit Function
end If
End if
end if
End if
next
End if
GetProfileString = ""
End Function
Function MyTrim(mystring)
Dim start, Endpos, i
start = 1
For i = 1 To Len(mystring)
If Mid(mystring, i, 1) = vbTab Or Mid(mystring, i, 1) = " " Then
start = i + 1
Else
Exit For
End If
Next
Endpos = Len(mystring)
For i = Len(mystring) To 1 Step -1
If Mid(mystring, i, 1) = vbTab Or Mid(mystring, i, 1) = " " Then
Endpos = i - 1
Else
Exit For
End If
Next
If (Endpos - start + 1) < 0 Then
MyTrim = ""
Exit Function
End If
MyTrim = Mid(mystring, start, Endpos - start + 1)
End Function
Sub WriteToLog(strMessage)
on error resume next
Dim fLogFile
Set fLogFile = FSO.OpenTextFile(szLogFileName, 8, True)
fLogFile.WriteLine CustomNow & ": " & strMessage
fLogFile.Close
CheckLogFileSize szLogFileName
End Sub
Function CustomNow()
Dim d: d = now
CustomNow = N2S(Year(d)) & "." & N2S(Month(d)) & "." & N2S(Day(d)) & " " & N2S(Hour(d)) & "." & N2S(Minute(d)) & "." & N2S(Second(d))
End Function
Function N2S(Number)
Dim s
s = CStr(Number)
If Len(s) = 1 Then s = "0" + s
If Len(s) > 2 Then s = Right(s, 2)
N2S = s
End Function
Sub CheckLogFileSize(szLogFullPath)
Dim f, FileSize, strContents, PosToCut
Set f = FSO.GetFile(szLogFullPath)
If f.Size <= nMaxLogSize Then Exit Sub
FileSize = f.Size
Set f = FSO.OpenTextFile(szLogFullPath, 1, True)
strContents = f.ReadAll
f.Close
PosToCut = InStr(FileSize - MaxLogSize, strContents, vbNewLine)
strContents = Right(strContents, FileSize - PosToCut - 1)
Set f = FSO.OpenTextFile(szLogFullPath, 2, True)
f.Write strContents
f.Close
End Sub |