Цитата Dosmod:
|
... а тут утилита нужна...
|
Можно и без утилиты - сценарием.
Цитата Dosmod:
|
... долго сканит компьютеры...
|
Да, это самый медленный способ, но зато наиболее достоверный.
Когда-то писал себе такой сценарий:
Код:
Dim objWsNet, strDomain, strThisComputer, strTranslator, blnIsConsole
Dim objWShell, objExec, objOutStream
Dim strUser, strTemp, strTemp2, xAnswer
Dim objDict, strKey
Dim objFS, objFile, strList, strLog
strLog = "LoggedUsers_List.log"
Set objFS = CreateObject("Scripting.FileSystemObject")
strTranslator = objFS.GetBaseName(WScript.FullName)
If StrComp(strTranslator, "cscript", vbTextCompare) = 0 Then
blnIsConsole = True
Else
blnIsConsole = False
End If
Set objWShell = CreateObject("WScript.Shell")
If Not blnIsConsole Then
xAnswer = MsgBox("Сценарий ориентирован на консольный режим." & vbNewLine & "Перезапустить его с помощью консоли?", vbYesNo + vbQuestion, "Выбор режима работы")
If xAnswer = vbNo Then
WScript.Echo "Выполнение сценария прекращено."
Else
objWShell.Run "cscript.exe " & WScript.ScriptFullName, 1
End If
Else
Set objWsNet = CreateObject("WScript.Network")
strDomain = objWsNet.UserDomain
strThisComputer = objWsNet.ComputerName
Set objWsNet = Nothing
Set objDict = CreateObject("Scripting.Dictionary")
objDict.CompareMode = 1
Call Comuters_List(objDict)
strUser = vbNullString
For Each strKey In objDict.Keys
If StrComp(strThisComputer, strKey, vbTextCompare) <> 0 Then
Set objExec = objWShell.Exec("ping -n 1 -w 130 " & strKey)
Set objOutStream = objExec.StdOut
strTemp = vbNullString
While Not objOutStream.AtEndOfStream
strTemp = strTemp & Trim(objOutStream.ReadLine())
Wend
If InStr(1, strTemp, "TTL", vbTextCompare) > 0 Then
strUser = Logged_Session(strKey, objDict.Item(strKey))
If Len(strKey) < 8 Then
strTemp = vbTab & vbTab
strTemp2 = vbTab & vbTab
Else
strTemp = vbTab
strTemp2 = vbTab & vbTab
End If
If Len(strUser) > 0 Then
If StrComp(strUser, "Error.", vbTextCompare) <> 0 Then
strList = strList & strKey & strTemp & " = " & strUser & vbNewLine
WScript.StdOut.WriteLine "[ + ] " & strKey & strTemp2 & " = " & strUser
Else
strList = strList & strKey & strTemp & " = Ошибка при определении сеанса" & vbNewLine
WScript.StdOut.WriteLine "[ + ] " & strKey & strTemp2 & " = Ошибка при определении сеанса"
End If
Else
WScript.StdOut.WriteLine "[ + ] " & strKey & strTemp2 & " = Сеанс не обнаружен"
End If
Else
WScript.StdOut.WriteLine "[ - ] " & strKey
End If
End If
Next
Set objOutStream = Nothing
Set objExec = Nothing
If objDict.Count > 0 Then
strLog = objFS.BuildPath(objFS.GetParentFolderName(WScript.ScriptFullName), strLog)
Set objFile = objFS.CreateTextFile(strLog, True)
objFile.Write strList
objFile.Close
Set objFile = Nothing
objWShell.Run "notepad.exe " & strLog, 1
objDict.RemoveAll
Else
WScript.Echo "Ничего не найдено."
End If
Set objDict = Nothing
End If
Set objWShell = Nothing
Set objFS = Nothing
WScript.Quit 0
'=====
Function Comuters_List(objDictionary)
Dim objRootDSE, strDomain, strTemp, blnTemp
Dim objConnection, objCommand, objRSet
Const ADS_SCOPE_SUBTREE = 2
Const ADS_UF_ACCOUNTDISABLE = 2
Set objRoot = GetObject("LDAP://RootDSE")
strDomain = objRoot.Get("DefaultNamingContext")
Set objRoot = Nothing
Set objConnection = CreateObject("ADODB.Connection")
objConnection.Provider = "ADsDSOObject"
objConnection.Open "Active Directory Provider"
Set objCommand = CreateObject("ADODB.Command")
Set objCommand.ActiveConnection = objConnection
strCommandText = "SELECT cn,userAccountControl,operatingSystem FROM 'LDAP://" & strDomain & "' WHERE objectCategory='Computer'"
objCommand.CommandText = strCommandText
objCommand.Properties("Page Size") = 1000
objCommand.Properties("Timeout") = 30
objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
Set objRSet = objCommand.Execute
objRSet.MoveFirst
Do
If Not (objRSet.Fields("userAccountControl").Value And ADS_UF_ACCOUNTDISABLE) Then
strTemp = objRSet.Fields("operatingSystem").Value
If Not IsNull(strTemp) Then
If InStr(1, strTemp, "server", vbTextCompare) = 0 Then
If InStr(1, strTemp, "2000", vbTextCompare) > 0 Then
blnTemp = False
Else
blnTemp = True
End If
strTemp = objRSet.Fields("cn").Value
If Not objDictionary.Exists(strTemp) Then
objDictionary.Add strTemp, blnTemp
End If
End If
End If
End If
objRSet.MoveNext
Loop While Not objRSet.EOF
Set objRSet = Nothing
Set objCommand = Nothing
objConnection.Close
Set objConnection = Nothing
Call Sorting_Dictionary(objDictionary)
End Function
'=====
Function Logged_Session(strComputer, blnFlag)
Dim objWMI, objCollection, objItem, strName, strTemp
Dim strParamName
Const HKLM = &H80000002
Const strSubKeyName = "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon"
strParamName = "DefaultUserName"
strName = vbNullString
On Error Resume Next
If blnFlag Then
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
If Err.Number = 0 Then
Set objCollection = objWMI.ExecQuery("SELECT UserName FROM Win32_ComputerSystem")
If Err.Number = 0 Then
For Each objItem In objCollection
strName = objItem.UserName
If Err.Number <> 0 Then
Err.Clear
strName = "Error."
End If
Next
Else
Err.Clear
strName = "Error."
End If
Set objItem = Nothing
Set objCollection = Nothing
Else
Err.Clear
strName = "Error."
End If
Else
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
If Err.Number = 0 Then
objWMI.GetStringValue HKLM, strSubKeyName, strParamName, strName
If Err.Number = 0 Then
If Len(strName) = 0 Then
strName = "идентифицировать сеанс не удалось"
Else
strName = strName & " (актуальность данных не гарантирована)"
strParamName = "DefaultDomainName"
objWMI.GetStringValue HKLM, strSubKeyName, strParamName, strTemp
If Err.Number = 0 Then
If Len(strTemp) > 0 Then
strName = strTemp & "\" & strName
End If
Else
Err.Clear
End If
End If
Else
Err.Clear
strName = "Error."
End If
Else
Err.Clear
strName = "Error."
End If
End If
Set objWMI = Nothing
On Error GoTo 0
Logged_Session = strName
End Function
Проверен для версий 2000 - 7 (не опрашивает компьютеры с ОС серверного типа).
Из-за особенностей "двухтысячной" версии достоверность того, что в настоящий момент сеанс открыт не гарантирована: нужны дополнительные проверки, но они отнимают довольно много времени.
