Полезные VBS скрипты и программы по работе с ними

Rem Отправка на FTP и копирование ссылки в буфер (Visual Basic Script)
Dim objArgs, Server, DomainName, Port, User, Pass, Folder, rootFolder, CloseDOS, DosStr
 
'=== Данные учетной записи FTP ===
 
Server = "31.170.164.47"
DomainName = "http://Dragokas.16mb.com"
Port = "21"
User = "***"
Pass = "***"
 
'Папка на FTP, куда будут складываться файлы
rootFolder = "public_html" 'корневая
Folder = "Forum/Dl" 'подкаталог
 
'Флаг - закрывать консольное окно после передачи данных
CloseDOS = True
if not CloseDOS then DosStr = "&pause"
 
Set objArgs = wscript.Arguments
If objArgs.Count <> 0 Then 'Проверяем аргументы (Drag & Drop "путь к файлу")
    Dim FName, WSHShell, Link, FF, TmpFile, objFile
    
    'Получаем имя файла
    FName = Mid(objArgs(0), InStrRev(objArgs(0), "\") + 1)
    'Интернет-адрес
    Link = DomainName & "/" & Folder & "/" & FName
 
    Set WSHShell = CreateObject("WScript.Shell")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'Копируем в буфер обмена Windows
    WSHShell.Run "cmd.exe /C <nul set /p ""=" & Link & """ | CLIP", 0, False
 
    'Формируем строку коннекта для утилиты FTP
    TmpFile = WSHShell.ExpandEnvironmentStrings("%temp%") & "\temp_" & CInt(Rnd() * 1000)   
    'ForAppending = 8, ForReading = 1, ForWriting = 2
    Set objFile = objFSO.OpenTextFile (TmpFile, 2, True, 0) 'True - создать файл
        objFile.WriteLine "open " & Server & " " & Port
        objFile.WriteLine User
        objFile.WriteLine Pass
        objFile.WriteLine "cd " & rootFolder & "/" & Folder
        objFile.WriteLine "binary"
        objFile.WriteLine "put """ & objArgs(0) & """"
        objFile.WriteLine "disconnect"
        objFile.WriteLine "bye"
    objFile.Close
    
    'Добавляем утилиту FTP в исключения файрвола и запускаем
    WSHShell.Run "cmd.exe /c ""(netsh firewall add allowedprogram """ & WSHShell.ExpandEnvironmentStrings("%windir%") & _
      "\system32\ftp.exe"" ENABLE& ftp -s:""" & TmpFile & """" & DosStr & ")""", 1, True
 
    objFSO.DeleteFile TmpFile, True
 
    Set WSHShell = Nothing: Set objFile = Nothing: Set objFSO = Nothing
    
    wscript.echo "Путь к файлу на FTP: " & vbLf & Link & String(2, vbLf) & _
    "Путь к файлу скопирован в буфер обмена Windows."
  Else
    wscript.echo "Перетащите файл на VBS-сценарий"
End If
Set objArgs = Nothing

'Установка ключа "Требовать смену пароля при следующем входе в систему"
'для заданной учётной записи пользователя домена.
'Сценарий ориентирован на работу в графическом режиме.
Dim objRoot, strDomain
Dim objConnection, objCommand, objRSet
Dim strUser, objUser, lngUserAC, xAnswer
Const ADS_SCOPE_SUBTREE = 2
Const ADS_UF_DONT_EXPIRE_PASSWD = 65536
 
xAnswer = vbNo
Do
    strUser = Trim(InputBox("Имя пользователя:", "Требование смены пароля"))
    If Len(strUser) > 0 Then
        '--- Поиск учётной записи пользователя
        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
        objCommand.Properties("Page Size") = 1000
        objCommand.Properties("Timeout") = 30
        objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
        objCommand.CommandText = "SELECT ADsPath,userAccountControl FROM 'LDAP://" & strDomain & _
                                    "' WHERE objectCategory='Person' AND objectClass='User' AND cn='" & strUser & "'"
        On Error Resume Next
        Set objRSet = objCommand.Execute
        '------
        If Err.Number = 0 Then
            If objRSet.RecordCount > 0 Then
                '--- Привязка к учётной записи пользователя
                objRSet.MoveFirst
                Set objUser = GetObject(objRSet.Fields("ADsPath").Value)
                '------
                '--- Определение состояния свойства "Срок действия пароля не ограничен" и (при необходимости) его сброс
                If CBool(objRSet.Fields("userAccountControl").Value And ADS_UF_DONT_EXPIRE_PASSWD) Then
                    'Свойство "Срок действия пароля не ограничен" определено положительно
                    '--- Сброс ключа "Срок действия пароля не ограничен"
                    lngUserAC = objUser.Get("userAccountControl")
                    lngUserAC = lngUserAC Xor ADS_UF_DONT_EXPIRE_PASSWD
                    objUser.Put "userAccountControl", lngUserAC
                    If Err.Number = 0 Then
                        objUser.SetInfo
                        If Err.Number <> 0 Then
                            MsgBox "Ошибка сохранения свойств учётной записи пользователя" & vbNewLine & _
                                    "при настройке атрибута ""userAccountControl""." & vbNewLine & Err.Description, _
                                    vbCritical, "Требование смены пароля"
                            Err.Clear
                            WScript.Quit -1
                        End If
                    Else
                        MsgBox "Ошибка " & Err.Number & " настройки атрибута ""userAccountControl""." & vbNewLine & Err.Description, _
                                vbCritical, "Требование смены пароля"
                        Err.Clear
                        WScript.Quit -1
                    End If
                    '------
                End If
                '------
                '--- Установка ключа "Требовать смену пароля при следующем входе в систему"
                objUser.Put "pwdLastSet", 0
                objUser.SetInfo
                If Err.Number = 0 Then
                    MsgBox "Ключ ""Требовать смену пароля при следующем входе в систему""" & vbNewLine & _
                            "успешно установлен.", vbInformation, "Требование смены пароля"
                Else
                    MsgBox "Ошибка при установке ключа" & vbNewLine & _
                            """Требовать смену пароля при следующем входе в систему""." & vbNewLine & _
                            Err.Description, vbCritical, "Требование смены пароля"
                    Err.Clear
                End If
                '------
                Set objUser = Nothing
            Else
                MsgBox "Учётная запись пользователя " & UCase(strUser) & " не обнаружена.", _
                        vbExclamation, "Требование смены пароля"
            End If
        Else
            MsgBox "Ошибка " & Err.Number & " при выполнении запроса." & vbNewLine & _
                    Err.Description, vbCritical, "Требование смены пароля"
            Err.Clear
        End If
        Set objRSet = Nothing
        Set objCommand = Nothing
        objConnection.Close
        Set objConnection = Nothing
        On Error GoTo 0
    Else
            xAnswer = MsgBox("Завершить работу?", vbYesNo + vbQuestion, "Требование смены пароля")
    End If
Loop While xAnswer = vbNo
WScript.Quit 0

'Очистка пароля заданной учётной записи пользователя домена.
'Сценарий ориентирован на работу в графическом режиме.
Dim objRoot, strDomain
Dim objConnection, objCommand, objRSet
Dim strUser, objUser, lngUserAC, xAnswer
Const ADS_SCOPE_SUBTREE = 2
Const ADS_UF_DONT_EXPIRE_PASSWD = 65536
 
xAnswer = vbNo
Do
    strUser = Trim(InputBox("Имя пользователя:", "Очистка пароля пользователя"))
    If Len(strUser) > 0 Then
        '--- Поиск учётной записи пользователя
        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
        objCommand.Properties("Page Size") = 1000
        objCommand.Properties("Timeout") = 30
        objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
        objCommand.CommandText = "SELECT ADsPath,userAccountControl FROM 'LDAP://" & strDomain & _
                                    "' WHERE objectCategory='Person' AND objectClass='User' AND cn='" & strUser & "'"
        On Error Resume Next
        Set objRSet = objCommand.Execute
        '------
        If Err.Number = 0 Then
            If objRSet.RecordCount > 0 Then
                '--- Привязка к учётной записи пользователя
                objRSet.MoveFirst
                Set objUser = GetObject(objRSet.Fields("ADsPath").Value)
                '------
                '--- Определение состояния свойства "Срок действия пароля не ограничен" и (при необходимости) его сброс
                If CBool(objRSet.Fields("userAccountControl").Value And ADS_UF_DONT_EXPIRE_PASSWD) Then
                    'Свойство "Срок действия пароля не ограничен" определено положительно
                    '--- Сброс ключа "Срок действия пароля не ограничен"
                    lngUserAC = objUser.Get("userAccountControl")
                    lngUserAC = lngUserAC Xor ADS_UF_DONT_EXPIRE_PASSWD
                    objUser.Put "userAccountControl", lngUserAC
                    If Err.Number = 0 Then
                        objUser.SetInfo
                        If Err.Number <> 0 Then
                                MsgBox "Ошибка сохранения свойств учётной записи пользователя" & vbNewLine & _
                                        "при настройке атрибута ""userAccountControl""." & vbNewLine & Err.Description, _
                                        vbCritical, "Очистка пароля пользователя"
                                Err.Clear
                                WScript.Quit -1
                        End If
                    Else
                        MsgBox "Ошибка настройки атрибута ""userAccountControl""." & vbNewLine & Err.Description, _
                                vbCritical, "Очистка пароля пользователя"
                        Err.Clear
                        WScript.Quit -1
                    End If
                    '------
                End If
                '------
                '--- Очистка пароля
                objUser.SetPassword ""
                objUser.SetInfo
                If Err.Number = 0 Then
                    '--- Установка состояния свойства "Требовать смену пароля при следующем входе в систему"
                    xAnswer = MsgBox("Задать требование смены пароля при следующем входе пользователя в систему?", _
                                        vbYesNo + vbQuestion, "Очистка пароля пользователя")
                    If xAnswer = vbYes Then
                        objUser.Put "pwdLastSet", 0
                        objUser.SetInfo
                        If Err.Number = 0 Then
                            MsgBox "Пустое значение пароля и требование смены пароля" & vbNewLine & _
                                    "при следующем входе пользователя в систему успешно заданы.", _
                                    vbInformation, "Очистка пароля пользователя"
                        Else
                            MsgBox "Ошибка при задании требования смены пароля" & vbNewLine & _
                                    "при следующем входе пользователя в систему." & vbNewLine & _
                                    Err.Description, vbCritical, "Очистка пароля пользователя"
                            Err.Clear
                        End If
                    End If
                    '------
                Else
                    MsgBox "Ошибка при попытке задания пустого значения пароля." & vbNewLine & Err.Description, _
                            vbCritical, "Очистка пароля пользователя"
                    Err.Clear
                End If
                Set objUser = Nothing
                '------
            Else
                MsgBox "Учётная запись пользователя " & UCase(strUser) & " не обнаружена.", _
                        vbExclamation, "Очистка пароля пользователя"
            End If
        Else
            MsgBox "Ошибка " & Err.Number & " при выполнении запроса." & vbNewLine & _
                    Err.Description, vbCritical, "Очистка пароля пользователя"
            Err.Clear
        End If
        Set objRSet = Nothing
        Set objCommand = Nothing
        objConnection.Close
        Set objConnection = Nothing
        On Error GoTo 0
    Else
        xAnswer = MsgBox("Завершить работу?", vbYesNo + vbQuestion, "Очистка пароля пользователя")
    End If
Loop While xAnswer = vbNo
WScript.Quit 0

'Управление настройками пароля для всех членов заданной группы пользователей домена:
'- включение|выключение режима "Требовать смену пароля при следующем входе в систему"
'  (атрибут "pwdLastSet");
'- очистка пароля.
'Дополнительная функция - возможность включения отключенных записей членов группы.
'Сценарий ориентирован на работу в графическом режиме.
Dim objRoot, strDomain
Dim objConnection, objCommand, objRSet
Dim strGroup, objGroup, objMember, objUser
Dim intTemp, lngUserAC, xAnswer, strTemp
Dim blnHasError, blnAccountOn, blnClearPassword
Const ADS_SCOPE_SUBTREE = 2
Const ADS_UF_DONT_EXPIRE_PASSWD = 65536
 
xAnswer = vbNo
Do
    strGroup = Trim(InputBox("Имя группы:", "Управление настройками пароля членов группы"))
    If Len(strGroup) > 0 Then
        '--- Поиск объекта группы
        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
        objCommand.Properties("Page Size") = 1000
        objCommand.Properties("Timeout") = 30
        objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
        objCommand.CommandText = "SELECT ADsPath FROM 'LDAP://" & strDomain & _
                                    "' WHERE objectCategory='Group' AND cn='" & strGroup & "'"
        On Error Resume Next
        Set objRSet = objCommand.Execute
        '------
        If Err.Number = 0 Then
            If objRSet.RecordCount > 0 Then
                intTemp = Trim(InputBox("Код действия:" & vbNewLine & "0 - отключить требование и не очищать пароль" & vbNewLine & _
                            "1 - отключить требование и очистить пароль" & vbNewLine & _
                            "2 - включить требование и не очищать пароль" & vbNewLine & _
                            "3 - включить требование и очистить пароль", "Управление настройками пароля членов группы"))
                If Len(intTemp) > 0 Then
                    If intTemp = "0" Or intTemp = "1" Or intTemp = "2" Or intTemp = "3" Then
                        Select Case intTemp
                            Case "0"
                                intMode = -1
                                blnClearPassword = False
                            Case "1"
                                intMode = -1
                                blnClearPassword = True
                            Case "2"
                                intMode = 0
                                blnClearPassword = False
                            Case "3"
                                intMode = 0
                                blnClearPassword = True
                        End Select
                        If MsgBox("Включать отключенные учётные записи?", vbYesNo + vbQuestion, _
                                "Управление настройками пароля членов группы") = vbYes Then blnAccountOn = True
                        '--- Привязка к объекту группы
                        objRSet.MoveFirst
                        Set objGroup = GetObject(objRSet.Fields("ADsPath").Value)
                        '------
                        For Each objMember In objGroup.Members
                            blnHasError = False
                            '--- Определение состояния свойства "Срок действия пароля не ограничен" и (при необходимости) его сброс
                            lngUserAC = objMember.Get("userAccountControl")
                            If CBool(lngUserAC And ADS_UF_DONT_EXPIRE_PASSWD) Then
                                'Свойство "Срок действия пароля не ограничен" определено положительно
                                '--- Сброс ключа "Срок действия пароля не ограничен"
                                lngUserAC = lngUserAC Xor ADS_UF_DONT_EXPIRE_PASSWD
                                objMember.Put "userAccountControl", lngUserAC
                                If Err.Number = 0 Then
                                    objMember.SetInfo
                                    If Err.Number <> 0 Then
                                        Err.Clear
                                        strTemp = strTemp & objMember.cn & " -> ошибка сохранения свойств учётной записи" & vbNewLine
                                        blnHasError = True
                                    End If
                                Else
                                    Err.Clear
                                    strTemp = strTemp & objMember.cn & " -> ошибка настройки атрибута ""userAccountControl""" & vbNewLine
                                    blnHasError = True
                                End If
                                '------
                            End If
                            '------
                            '--- Очистка пароля
                            If blnClearPassword Then
                                objMember.SetPassword ""
                                objMember.SetInfo
                                If Err.Number <> 0 Then
                                    Err.Clear
                                    strTemp = strTemp & objMember.cn & " -> ошибка при очистке пароля" & vbNewLine
                                    blnHasError = True
                                End If
                            End If
                            '------
                            If Not blnHasError Then
                                '--- Установка режима "Требовать смену пароля при следующем входе в систему"
                                objMember.Put "pwdLastSet", intMode
                                If Err.Number = 0 Then
                                    objMember.SetInfo
                                    If Err.Number = 0 Then
                                        '--- Включение учётной записи (при необходимости)
                                        If blnAccountOn And objMember.AccountDisabled Then
                                            objMember.AccountDisabled = False
                                            objMember.SetInfo
                                            If Err.Number <> 0 Then
                                                Err.Clear
                                                strTemp = strTemp & objMember.cn & " -> ошибка при включении учётной записи" & vbNewLine
                                            End If
                                        End If
                                        '------
                                    Else
                                        Err.Clear
                                        strTemp = strTemp & objMember.cn & " -> ошибка сохранения после настройки атрибута ""pwdLastSet""" & vbNewLine
                                    End If
                                Else
                                    Err.Clear
                                    strTemp = strTemp & objMember.cn & " -> ошибка при настройке атрибута ""pwdLastSet""" & vbNewLine
                                End If
                                '------
                            End If
                        Next
                        Set objMember = Nothing
                        Set objGroup = Nothing
                        If Len(strTemp) = 0 Then
                            MsgBox "Группа " & UCase(strGroup) & " обработана успешно.", vbInformation, "Управление настройками пароля членов группы"
                        Else
                            MsgBox "Ошибки при обработке записей пользователей:" & vbNewLine & vbNewLine & strTemp, vbExclamation, "Управление настройками пароля членов группы"
                        End If
                    Else
                        MsgBox "Неверный код действия: " & intTemp, vbCritical, "Управление настройками пароля членов группы"
                    End If
                Else
                    xAnswer = MsgBox("Завершить работу?", vbYesNo + vbQuestion, "Управление настройками пароля членов группы")
                End If
            Else
                MsgBox "Объект группы " & UCase(strGroup) & " не обнаружен.", _
                        vbExclamation, "Управление настройками пароля членов группы"
            End If
        Else
            MsgBox "Ошибка " & Err.Number & " при выполнении запроса." & vbNewLine & _
                    Err.Description, vbCritical, "Управление настройками пароля членов группы"
            Err.Clear
        End If
        Set objRSet = Nothing
        Set objCommand = Nothing
        objConnection.Close
        Set objConnection = Nothing
        On Error GoTo 0
    Else
        xAnswer = MsgBox("Завершить работу?", vbYesNo + vbQuestion, "Управление настройками пароля членов группы")
    End If
Loop While xAnswer = vbNo
WScript.Quit 0

'Определение даты последней регистрации сеанса пользователя в многоконтроллерном домене
'с возможностью включения|отключения соответствующей учётной записи.
'Сценарий ориентирован на работу в графическом режиме.
Dim objRoot, strDomain, objServers, objItem
Dim objConnection, objCommand, objRSet, strCommandText, strAttributes
Dim strList, arrTemp(), xAnswer, strUser, strTemp, blnStatus
Dim objUser, dtmLastLogon, dtmTemp, strServer, i
Const ADS_SCOPE_SUBTREE = 2
 
'Определение имени домена и формирование списка контроллеров домена
Set objRoot = GetObject("LDAP://RootDSE")
strDomain = objRoot.Get("DefaultNamingContext")
Set objServers = GetObject(GetObject("LDAP://" & objRoot.Get("serverName")).Parent)
i = 0
For Each objItem In objServers
    strTemp = objItem.cn
    If Available(strTemp) Then
        ReDim Preserve arrTemp(i)
        arrTemp(i) = strTemp
        i = i + 1
    End If
Next
Set objItem = Nothing
Set objServers = Nothing
Set objRoot = Nothing
 
'Поиск учётной записи пользователя и определение даты последней регистрации сеанса
xAnswer = vbNo
Do
    strUser = Trim(InputBox("Имя пользователя:", "Дата последней регистрации сеанса пользователя"))
    If Len(strUser) > 0 Then
        'Настройка параметров запроса и поиск учётной записи заданного пользователя
        Set objConnection = CreateObject("ADODB.Connection")
        objConnection.Provider = "ADsDSOObject"
        objConnection.Open "Active Directory Provider"
        Set objCommand = CreateObject("ADODB.Command")
        Set objCommand.ActiveConnection = objConnection
        strAttributes = "distinguishedName,samAccountName,userPrincipalName"
        strCommandText = "SELECT " & strAttributes & " FROM 'LDAP://" & strDomain & _
                        "' WHERE objectCategory='Person' AND objectClass='User' AND (userPrincipalName='" & strUser & _
                        "' OR samAccountName='" & strUser & "')"
        objCommand.CommandText = strCommandText
        objCommand.Properties("Page Size") = 1000
        objCommand.Properties("Timeout") = 30
        objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
        Set objRSet = objCommand.Execute
        If objRSet.RecordCount = 1 Then
            objRSet.MoveFirst
            strTemp = objRSet.Fields("distinguishedName").Value
            'Поиск наиболее поздней даты регистрации сеанса заданного пользователя
            dtmLastLogon = DateValue("01.01.1601"): strServer = vbNullString
            On Error Resume Next
            For i = 0 To UBound(arrTemp)
                Set objUser = GetObject("LDAP://" & arrTemp(i) & "/" & strTemp)
                dtmTemp = objUser.LastLogin
                blnStatus = objUser.AccountDisabled
                If Err.Number = 0 Then
                    If i = 0 Or dtmLastLogon < dtmTemp Then
                        dtmLastLogon = dtmTemp
                        strServer = arrTemp(i)
                    End If
                Else
                    Err.Clear
                End If
            Next
            If dtmLastLogon = DateValue("01.01.1601") Then
                MsgBox "Искомые сведения не обнаружены.", vbInformation, "Информация о пользователе " & UCase(strUser)
            Else
                If blnStatus Then
                    strTemp = "Сейчас учётная запись отключена. Включить?"
                Else
                    strTemp = "Сейчас учётная запись включена. Отключить?"
                End If
                xAnswer = MsgBox("Текущая дата: " & Date & vbNewLine & vbNewLine & "======" & vbNewLine & vbNewLine & _
                            "Дата последней регистрации сеанса: " & Fix(dtmLastLogon) & vbNewLine & _
                            "Сервер, открывший сеанс: " & strServer & vbNewLine & vbNewLine & _
                            "======" & vbNewLine & vbNewLine & strTemp, _
                            vbYesNo + vbDefaultButton2 + vbQuestion, "Информация о пользователе " & UCase(strUser))
                If xAnswer = vbYes Then
                    objUser.AccountDisabled = Not blnStatus
                    objUser.SetInfo
                    If Err.Number = 0 Then
                        If blnStatus Then
                            MsgBox "Учётная запись успешно включена.", vbInformation, "Информация о пользователе " & UCase(strUser)
                        Else
                            MsgBox "Учётная запись успешно отключена.", vbInformation, "Информация о пользователе " & UCase(strUser)
                        End If
                    Else
                        MsgBox Err.Number & vbNewLine & Err.Description, vbCritical, "Ошибка"
                        Err.Clear
                    End If
                    xAnswer = vbNo
                End If
            End If
            On Error GoTo 0
            Set objUser = Nothing
        Else
            MsgBox "Учётная запись пользователя " & UCase(strUser) & " не обнаружена.", vbExclamation, "Предупреждение"
        End If
        Set objRSet = Nothing
        Set objCommand = Nothing
        objConnection.Close
        Set objConnection = Nothing
    Else
        xAnswer = MsgBox("Завершить работу?", vbYesNo + vbQuestion, "Выбор продолжения")
    End If
Loop While xAnswer = vbNo
WScript.Quit 0
 
'======
 
Function Available(strName)
Dim objWMI, objItem
 
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("SELECT * FROM Win32_PingStatus WHERE Address='" & strName & "'")
For Each objItem In objWMI
    If IsNull(objItem.StatusCode) Then
        Available = False
    Else
        Available = (objItem.StatusCode = 0)
    End If
Next
Set objItem = Nothing
Set objWMI = Nothing
End Function

'Поиск учётных записей пользователей домена, имеющих ограничения в списке станций,
'на которые им разрешён интерактивный вход.
'Сценарий ориентирован на работу в консольном режиме.
Dim objFS, objFile, strLog, strTranslator, strList, strTemp, blnIsConsole, xAnswer
Dim objRoot, strDomain
Dim objConnection, objCommand, objRSet
Const ADS_SCOPE_SUBTREE = 2
 
strLog = "UserWorkstations_Result.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
        MsgBox "Выполнение сценария прекращено.", vbInformation, "Ограничение входа пользователей на станции"
    Else
        objWShell.Run "cscript.exe " & WScript.ScriptFullName, 1
    End If
Else
    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
    strAttributes = "cn,userWorkstations"
    strCommandText = "SELECT " & strAttributes & " FROM 'LDAP://" & strDomain & _
                        "' WHERE objectCategory='Person' AND objectClass='User'"
    objCommand.CommandText = strCommandText
    objCommand.Properties("Page Size") = 1000
    objCommand.Properties("Timeout") = 30
    objCommand.Properties("Sort On") = "cn"
    objCommand.Properties("Searchscope") = ADS_SCOPE_SUBTREE
    Set objRSet = objCommand.Execute
    objRSet.MoveFirst
    Do
        If Not IsNull(objRSet.Fields("userWorkstations").Value) Then
            strTemp = objRSet.Fields("cn").Value & " = " & objRSet.Fields("userWorkstations").Value
            strList = strList & strTemp & vbNewLine
            WScript.Echo strTemp
        End If
        objRSet.MoveNext
    Loop While Not objRSet.EOF
    Set objRSet = Nothing
    Set objCommand = Nothing
    objConnection.Close
    Set objCommand = Nothing
    If Len(strList) > 0 Then
        strLog = objFS.BuildPath(objFS.GetParentFolderName(WScript.ScriptFullName), strLog)
        Set objFile = objFS.CreateTextFile(strLog, True)
        objFile.Write strList
        objFile.Close
        Set objFile = Nothing
        WScript.Echo "Путь к файлу журнала: " & UCase(strLog)
    End If
End If
Set objWShell = Nothing
Set objFS = Nothing
WScript.Quit 0

'Получение списка всех контроллеров домена с указанием формального уровня
'их иерархии (основной|дополнительный), наличием роли глобального каталога
'и распределением FSMO между ними.
'Сценарий способен работать и в графическом, и в консольном режимах.
Dim objRoot, objServers, objSrv, objNTDS
Dim strDomain, arrBinds, arrFSMO, strList, intTemp, i
Dim objWMI, objCollection, objItem
Const NTDSDSA_OPT_IS_GC = 1
 
On Error Resume Next
Set objRoot = GetObject("LDAP://RootDSE")
If Err.Number = 0 Then
    strDomain = objRoot.Get("defaultNamingContext")
    If Err.Number = 0 Then
        Set objServers = GetObject("LDAP://cn=Servers,cn=Default-First-Site-Name,cn=Sites,cn=Configuration," & strDomain)
        If Err.Number = 0 Then
            strList = "Контроллеры:" & vbNewLine
            '--- Формирование списка контроллеров
            For Each objSrv In objServers
                strList = strList & objSrv.cn
                '--- Определение формального уровня иерархии
                Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & objSrv.cn & "\root\cimv2")
                If Err.Number = 0 Then
                    Set objCollection = objWMI.ExecQuery("SELECT DomainRole FROM Win32_ComputerSystem")
                    For Each objItem In objCollection
                        If objItem.DomainRole = 5 Then
                            strList = strList & ", основной"
                        Else
                            strList = strList & ", дополнительный"
                        End If
                    Next
                Else
                    Err.Clear
                End If
                '------
                '--- Определение наличиия роли глобального каталога
                Set objNTDS = GetObject("LDAP://" & GetObject("LDAP://" & objSrv.cn & "/RootDSE").Get("dsServiceName"))
                intTemp = objNTDS.Get("options")
                If intTemp And NTDSDSA_OPT_IS_GC Then
                    strList = strList & ", глобальный каталог" & vbNewLine
                Else
                    strList = strList & vbNewLine
                End If
                '------
            Next
            '------
            Set objItem = Nothing: Set objCollection = Nothing: Set objWMI = Nothing: Set objNTDS = Nothing
            '--- Определение хозяев FSMO
            strList = strList & vbNewLine & "Хозяева FSMO:" & vbNewLine
            arrBinds = Array("LDAP://" & strDomain, "LDAP://" & objRoot.Get("schemaNamingContext"), _
                                "LDAP://CN=Partitions," & objRoot.Get("configurationNamingContext"), _
                                "LDAP://CN=RID Manager$,CN=System," & strDomain, "LDAP://CN=Infrastructure," & strDomain)
            arrFSMO = Array("эмулятор PDC - ", "схема - ", "именование домена - ", "относительные идентификаторы - ", "инфраструктура - ")
            For i = 0 To UBound(arrBinds)
                If Err.Number = 0 Then
                    Set objItem = GetObject(GetObject("LDAP://" & GetObject(arrBinds(i)).Get("fSMORoleOwner")).Parent)
                    If Err.Number = 0 Then
                        strList = strList & arrFSMO(i) & Mid(objItem.Name, 4) & vbNewLine
                    Else
                        strList = strList & arrFSMO(i) & "ошибка " & Err.Number & " привязки к объекту-хозяину" & vbNewLine
                        Err.Clear
                    End If
                Else
                    strList = strList & arrFSMO(i) & "ошибка " & Err.Number & " привязки к базовому объекту" & vbNewLine
                    Err.Clear
                End If
            Next
            Set objItem = Nothing
            '------
            WScript.Echo strList
        Else
            WScript.Echo "ошибка " & Err.Number & " привязки к контейнеру SERVERS" & vbNewLine
            Err.Clear
        End If
        Set objServers = Nothing
    Else
        WScript.Echo "ошибка " & Err.Number & " определения имени домена" & vbNewLine
        Err.Clear
    End If
Else
    WScript.Echo "ошибка " & Err.Number & " привязки к объекту RootDSE" & vbNewLine
    Err.Clear
End If
Set objRoot = Nothing
WScript.Quit 0

'Сопоставление логических томов, назначенных НЖМД и съёмным накопителям, с физическими устройствами.
'Типы съёмных накопителей, на работу с которыми ориентирован сценарий: Flash-диски, Flash-карты, ZIP-диски.
'Сценарий может работать и в консольном, и в графическом режимах.
Dim objWMI, objLogicalDisks, objLD
Dim objPartitions, objPart, objDrives, objDrive, objFS
Dim strComputer, strTranslator, strList, strTemp, blnIsConsole
 
strComputer = ".": strList = vbNullString
Set objFS = CreateObject("Scripting.FileSystemObject")
strTranslator = objFS.GetBaseName(WScript.FullName)
Set objFS = Nothing
If StrComp(strTranslator, "cscript", vbTextCompare) = 0 Then
    blnIsConsole = True
Else
    blnIsConsole = False
End If
Set objWMI = GetObject("winmgmts:{impersonationLevel=Impersonate}!\\" & strComputer & "\root\cimv2")
Set objLogicalDisks = objWMI.ExecQuery("SELECT * FROM Win32_LogicalDisk WHERE DriveType=2 OR DriveType=3")
For Each objLD In objLogicalDisks
    Set objPartitions = objWMI.ExecQuery("ASSOCIATORS OF {Win32_LogicalDisk.DeviceID=""" & _
                                        objLD.DeviceID & _
                                        """} WHERE AssocClass=Win32_LogicalDiskToPartition")
    For Each objPart In objPartitions
        Set objDrives = objWMI.ExecQuery("ASSOCIATORS OF {Win32_DiskPartition.DeviceID=""" & _
                                        objPart.DeviceID & _
                                        """} WHERE AssocClass=Win32_DiskDriveToDiskPartition")
        For Each objDrive In objDrives
                strTemp = objLD.DeviceID & " => " & objDrive.Caption & _
                                        " (Диск " & objDrive.Index & ", " & objDrive.DeviceID & ")"
                strList = strList & strTemp & vbNewLine
                If blnIsConsole Then WScript.Echo strTemp
        Next
        Set objDrive = Nothing
        Set objDrives = Nothing
    Next
    Set objPart = Nothing
    Set objPartitions = Nothing
Next
Set objLD = Nothing
Set objLogicalDisks = Nothing
Set objWMI = Nothing
If Len(strList) = 0 Then
    WScript.Echo "Накопителей указанного типа не обнаружено."
End If
If Not blnIsConsole Then WScript.Echo strList
WScript.Quit 0

Set objCollection = objWMI.ExecQuery("SELECT * FROM Win32_LogicalDisk WHERE DriveType=2 OR DriveType=3")

For Each objLD In objLogicalDisks
     Set objPartitions = objWMI.ExecQuery("ASSOCIATORS OF {Win32_LogicalDisk.DeviceID=""" & _
                            objLD.DeviceID & _
                            """} WHERE AssocClass=Win32_LogicalDiskToPartition")
'...
Next

For Each objPart In objPartitions
     Set objDrives = objWMI.ExecQuery("ASSOCIATORS OF {Win32_DiskPartition.DeviceID=""" & _
                          objPart.DeviceID & _
                          """} WHERE AssocClass=Win32_DiskDriveToDiskPartition")
     '...
Next

For Each objDrive In objDrives
     strTemp = strTemp & objLD.DeviceID & " => " & objDrive.Caption & " (Диск " & objDrive.Index & ")" & vbNewLine
Next

'Сценарий для показа членам заданной группы пользователей домена
'текста какого-либо уведомления (например, поздравления по случаю праздника).
'Текст уведомления представляет собой заранее созданную HTML-страницу
'и размещается в доменном каталоге "NETLOGON".
'Имя файла HTML-страницы и целевая группа пользователей указываются в тексте сценария
'(значения переменных "strExclamation" и "strGroup" соответственно).
'Имя группы представляет собой строку для LDAP-привязки к соответствующему объекту AD
'в формате значения арибута "ADsPath", но без части, содержащей имя домена.
'Показ уведомления зависит от даты, которая задаётся в сценарии парой "день + месяц"
'(значения переменнх "intDay" и "intMonth" соответственно).
'Сценарий ориентирован на использование в составе групповой политики пользователей.
 
Dim objADSysInfo, objRoot, objGroup, intDay, intMonth
Dim objWShell, strAddress, strCommand
Dim strDomain, strUserDN, strUser, strGroup
Dim objFS, strSource, strExclamation
 
intDay = 1: intMonth = 4
strExclamation = "Exclamation.html"
strGroup = "LDAP://CN=Congratulation,CN=Users,"
If Day(Date) = intDay And Month(Date) = intMonth Then
    On Error Resume Next
    Set objADSysInfo = CreateObject("ADSystemInfo")
    If Err.Number = 0 Then
        strUserDN = objADSysInfo.UserName
        If Err.Number = 0 Then
            Set objRoot = GetObject("LDAP://RootDSE")
            strDomain = objRoot.Get("DefaultNamingContext")
            Set objRoot = Nothing
            Set objGroup = GetObject(strGroup & strDomain)
            If Err.Number = 0 Then
                If objGroup.IsMember("LDAP://" & strUserDN) Then
                    strDomain = objADSysInfo.DomainDNSName
                    If Err.Number = 0 Then
                        strSource = "\\" & strDomain & "\NETLOGON"
                        Set objFS = CreateObject("Scripting.FileSystemObject")
                        If objFS.FolderExists(strSource) Then
                            strAddress = strSource & "\" & strExclamation
                            If objFS.FileExists(strAddress) Then
                                If objFS.FileExists("C:\Program Files\Mozilla Firefox\firefox.exe") Then
                                    strCommand = """C:\Program Files\Mozilla Firefox\firefox.exe """ & strAddress
                                Else
                                    strCommand = "iexplore.exe " & strAddress
                                End If
                                Set objWShell = CreateObject("WScript.Shell")
                                objWShell.Run strCommand, 1, True
                                Set objWShell = Nothing
                                If Err.Number <> 0 Then Err.Clear
                            End If
                        End If
                        Set objFS = Nothing
                    Else
                        Err.Clear
                    End If
                End If
            Else
                Err.Clear
            End If
            Set objGroup = Nothing
        Else
            Err.Clear
        End If
    Else
        Err.Clear
    End If
    Set objADSysInfo = Nothing
End If
WScript.Quit 0

'Ограничение количества одновременно работающих экземпляров заданного процесса на заданной станции домена.
'Процесс идентифицируется по имени исполняемого файла, станция - по NetBIOS-имени.
'Имена процесса и станции задаются в коде сценария (значения переменных "strProcess" и "strComputer").
'Сценарий позволяет запустить процесс либо в количестве, не большем, чем количество процессов
'на момент запуска сценария, либо в единственном экземпляре (если на момент запуска сценария
'не было запущено ни одного экземпляра контролируемого процесса).
'Сценарий ориентирован на работу в "молчаливом" режиме.
Dim objWMI, objCollection, objItem
Dim strComputer, strProcess, intLimit
Dim objDict, strHandle, strTemp
 
strComputer = "."
strProcess = "calc.exe"
Set objDict = CreateObject("Scripting.Dictionary")
Set objWMI = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set objCollection = objWMI.ExecQuery("SELECT Handle FROM Win32_Process WHERE Name='" & strProcess & "'")
If objCollection.Count = 0 Then
    intLimit = 1
Else
    For Each objItem In objCollection
        objDict.Add objItem.Handle, True
    Next
    intLimit = objDict.Count
End If
Set objCollection = objWMI.ExecNotificationQuery("SELECT * FROM __InstanceOperationEvent " _
        & "WITHIN 1 WHERE TargetInstance ISA 'Win32_Process' AND TargetInstance.Name='" & strProcess & "'")
'WScript.Echo "Начали: " & Time
On Error Resume Next
Do
    Set objItem = objCollection.NextEvent
    Select Case objItem.Path_.Class
        Case "__InstanceCreationEvent"
            strTemp = objItem.TargetInstance.Handle
            If objDict.Count < intLimit Then
                objDict.Add strTemp, True
            Else
                objWMI.Get("Win32_Process.Handle='" & strTemp & "'").Terminate
                If Err.Number <> 0 Then Err.Clear
            End If
        Case "__InstanceDeletionEvent"
            strTemp = objItem.TargetInstance.Handle
            If objDict.Exists(strTemp) Then
                objDict.Remove strTemp
            End If
    End Select
Loop
'WScript.Echo "Закончили: " & Time
Set objItem = Nothing
Set objCollection = Nothing
Set objWMI = Nothing
Set objDict = Nothing
WScript.Quit 0

Dim oFSO, oFolder, oFile
Dim i, j, MyPath, FCnt, Min, PoTemp, sTmp, sL, sR, Usl
With CreateObject("Word.Application")
    .Visible = True
    With .FileDialog(4)
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = "C:\"
        Usl = (.Show = -1)
        If Usl Then
            MyPath = .SelectedItems(1)
        End If
    End With
    .Quit
End With
If Usl Then
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(MyPath)
    MyPath = MyPath & "\"
    FCnt = oFolder.Files.Count
    ReDim OldNames(FCnt), NewNames(FCnt), Poryadok(FCnt), NewPrefix(FCnt)
    i = 0
    For Each oFile In oFolder.Files
        i = i + 1
        OldNames(i) = oFile.Name
        If Len(OldNames(i)) > 5 Then
            sTmp = Left(OldNames(i), 5)
            sR = Right(OldNames(i), Len(OldNames(i)) - 5)
            Usl = False
            sL = ""
            For j = 1 To 5
                PoTemp = Mid(sTmp, j, 1)
                Select Case PoTemp
                     Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
                        If j = 2 Then
                            Usl = True
                        End If
                     Case "_", " "
                        If Not Usl Then
                            sL = sL & PoTemp
                        End If
                     Case Else
                        sL = sL & PoTemp
                End Select
            Next
            NewNames(i) = sL & sR
        Else
            NewNames(i) = OldNames(i)
        End If
        Poryadok(i) = Rnd
        sTmp = Trim(CStr(i))
        j = Len(sTmp)
        If j < 4 Then
           sTmp = String(4 - j, "0") & sTmp
        End If
        NewPrefix(i) = sTmp & "_"
    Next
    Randomize Timer
    For i = 1 To FCnt
        Min = Poryadok(i)
        For j = i + 1 To FCnt
            If Min > Poryadok(j) Then
                PoTemp = Poryadok(i)
                Poryadok(i) = Poryadok(j)
                Poryadok(j) = PoTemp
                sTmp = NewPrefix(i)
                NewPrefix(i) = NewPrefix(j)
                NewPrefix(j) = sTmp
            End If
        Next
    Next
    For i = 1 To FCnt
        NewNames(i) = MyPath & NewPrefix(i) & NewNames(i)
        oFSO.GetFile(MyPath & OldNames(i)).Move NewNames(i)
    Next
    Set File = Nothing
    Set oFolder = Nothing
    Set oFSO = Nothing
End If

'Получение ряда сведений о заданном процессе на заданной станции домена:
'- идентификатор;
'- имя;
'- полный путь к исполняемому файлу;
'- владелец;
'- командная строка, использованная при запуске.
'Процесс идентифицируется по имени его исполняемого файла.
'Если имя станции не задано, выпоняется опрос текущей станции.
'Если имя процесса не задано, обрабатывается весь список процессов.
'Сценарий ориентирован на работу в графическом режиме.
Dim objWMI, objCollection, objItem
Dim objFS, objFile, objWShell
Dim strName, strList, strComputer, strTemp, strLog
 
strLog = "ProcessProperties_Result.log"
strComputer = Trim(InputBox("Имя станции:", "Свойства процессов"))
If Len(strComputer) = 0 Then
    strComputer = "."
Else
    If Not Available(strComputer) Then
        WScript.Echo "Станция " & UCase(strComputer) & " не отвечает."
        WScript.Quit 0
    End If
End If
On Error Resume Next
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate,(Debug)}!\\" & strComputer & "\root\cimv2")
If Err.Number = 0 Then
    strName = Trim(InputBox("Имя файла процесса:", "Свойства процессов"))
    If Len(strName) > 0 Then
        Set objCollection = objWMI.ExecQuery("SELECT * FROM Win32_Process WHERE Name='" & strName & "'")
    Else
        Set objCollection = objWMI.ExecQuery("SELECT * FROM Win32_Process")
    End If
    If Err.Number = 0 Then
        If objCollection.Count > 0 Then
            For Each objItem In objCollection
                If objItem.ProcessId > 4 Then
                    If objItem.GetOwner(strName) <> 0 Then strName = "не определён"
                    strList = strList & "ID: " & objItem.ProcessId & vbNewLine & "Имя: " & objItem.Name & vbNewLine & _
                            "Путь: " & objItem.ExecutablePath & vbNewLine & "Владелец: " & strName & vbNewLine & _
                            "Командная строка: " & objItem.CommandLine & vbNewLine & vbNewLine
                End If
            Next
            If Len(strList) > 0 Then
                Set objFS = CreateObject("Scripting.FileSystemObject")
                strLog = objFS.BuildPath(objFS.GetParentFolderName(WScript.ScriptFullName), strLog)
                Set objFile = objFS.CreateTextFile(strLog, True)
                objFile.Write Left(strList, Len(strList) - 2)
                objFile.Close
                Set objFile = Nothing
                Set objFS = Nothing
                Set objWShell = CreateObject("WScript.Shell")
                objWShell.Run "notepad.exe " & strLog, 1
                Set objWShell = Nothing
            Else
                WScript.Echo "Никаких сведений о процессе " & UCase(strName) & " получить не удалось."
            End If
        Else
            WScript.Echo "Процесс " & UCase(strName) & " не найден."
        End If
    Else
        WScript.Echo "Ошибка " & Err.Number & " при выполнении запроса." & vbNewLine & Err.Description
        Err.Clear
    End If
    Set objCollection = Nothing
Else
    WScript.Echo "Ошибка " & Err.Number & " при подключении к WMI-пространству." & vbNewLine & Err.Description
    Err.Clear
End If
Set objWMI = Nothing
WScript.Quit 0
 
'======
 
Function Available(strName)
Dim objWMI, objItem
 
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("SELECT * FROM Win32_PingStatus WHERE Address='" & strName & "'")
For Each objItem In objWMI
    If IsNull(objItem.StatusCode) Then
        Available = False
    Else
        Available = (objItem.StatusCode = 0)
    End If
Next
Set objItem = Nothing
Set objWMI = Nothing
End Function

'Определение типа сеанса (интерактивный/удалённый) текущего пользователя на текущем узле
'и внесение данных об интерактивном сеансе в заданном регистрационном каталоге.
'Путь к регистрационному каталогу задаётся в сценарии (значение переменной "strLogFolder").
'Сценарий ориентирован на использование в составе групповой политики пользователей
'и работу в "молчаливом" режиме.
Dim objSysInfo, strTemp, intTemp
Dim strComputer, strUser, strLogFolder
Dim objFS, objFile, objWMI, arrSubKeys
Const HKCU = &H80000001
 
strLogFolder = "\\server\folder\"
Set objSysInfo = CreateObject("ADSystemInfo")
strComputer = GetObject("LDAP://" & objSysInfo.ComputerName).cn
strUser = GetObject("LDAP://" & objSysInfo.UserName).cn
strTemp = LCase(GetObject("LDAP://" & objSysInfo.ComputerName).operatingSystemVersion)
Set objSysInfo = Nothing
If Len(strTemp) > 0 Then
    intTemp = CInt(Replace(Left(strTemp, 3), ".", ""))
    If intTemp > 52 Then
        Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
        objWMI.EnumKey HKCU, "Volatile Environment", arrSubKeys
        objWMI.GetStringValue HKCU, "Volatile Environment\" & arrSubKeys(UBound(arrSubKeys)), "SESSIONNAME", strTemp
        Set objWMI = Nothing
    Else
        strTemp = CreateObject("WScript.Shell").Environment("Volatile").Item("SESSIONNAME")
    End If
    If UCase(strTemp) = "CONSOLE" Then
        Set objFS = CreateObject("Scripting.FileSystemObject")
        If objFS.FolderExists(strLogFolder) Then
            Set objFile = objFS.OpenTextFile(strLogFolder & strUser & ".txt", 2, True)
            objFile.WriteLine Now & vbNewLine & strComputer
            objFile.Close
            Set objFile = Nothing
        End If
        Set objFS = Nothing
    End If
End If
WScript.Quit 0

'==========================================================================
'
' AUTHOR: Леонид_33
' NAME: HDD_Smart.vbs
'
' Скрипт для получения SMARTа HDD
' Может брать SMART как с локальной так и удаленной машины с выводом результата в файл в формате CSV
' При запуске скрипта выдается окно ввода имени(IP) машины с учетными данными
' Если хотим получить SMART с локальной машины, то ничего не указываем, если с удаленной, указываем имя(IP) машины, и, если надо, учетные данные
' Работает на WindowsXP(SP2,SP3), Windows2003SP2, Windows2008SP1
' Берет SMART через WMI, поэтому, что винда отдает, то отдает т.е.
' работает только со стандартно подключенными на мать HDD IDE и SATA
' Как бы того не хотелось, НЕ РАБОТАЕТ с рэйдами.
' Ну не видит винда SMARTов с этих винтов и все тут.
'
' Если что по атрибутам неясно, можно глянуть тут
' [url]http://en.wikipedia.org/wiki/Self-Monitoring%2C_Analysis%2C_and_Reporting_Technology[/url]
'
'==========================================================================
 
if not isAdminRights then call Elevate(""): WScript.Quit
 
Dim strComputer
Dim strLogin
Dim strPassword
On Error Resume Next
'GetPassword()
   strComputer = "."
   strLogin = ""
   strPassword = ""
 
 
If strLogin = "" or strComputer = "." then
   Set    objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\WMI")
else
   Set objSWbemLocator = CreateObject("WbemScripting.SWbemLocator")
   Set objWMIService = objSWbemLocator.ConnectServer(strComputer, _
      "root\CIMV2", _
      strLogin, _
      strPassword, _
      "MS_409")
end If
 
    Set    SmartDataItems = objWMIService.ExecQuery("SELECT * FROM MSStorageDriver_FailurePredictData", "WQL", 48)
 
    InstanceName = Array()
    SmartData = Array()
    SmartLength = Array()
    RowCount = 0
    For Each objItem In SmartDataItems
          Redim Preserve InstanceName(RowCount)
          InstanceName(RowCount) = objItem.InstanceName
          Redim Preserve SmartData(RowCount)
          SmartData(RowCount) = objItem.VendorSpecific
          Redim Preserve SmartLength(RowCount)
          SmartLength(RowCount) = objItem.Length
          RowCount = RowCount + 1
    Next
    Set    SmartDataItems = Nothing
 
    ThresholdData = Array()
    Redim Preserve ThresholdData(RowCount)
    PredictFailure = Array()
    Redim Preserve PredictFailure(RowCount)
    Reason = Array()
    Redim Preserve Reason(RowCount)
 
    RowCount = 0
    Set    ThresholdItems = objWMIService.ExecQuery("SELECT * FROM MSStorageDriver_FailurePredictThresholds", "WQL", 48)
    For Each objItem In ThresholdItems
          ThresholdData(RowCount) = objItem.VendorSpecific
          RowCount = RowCount + 1
    Next
    Set    ThresholdItems = Nothing
 
    RowCount = 0
    Set    PredictStatusItems = objWMIService.ExecQuery("SELECT * FROM MSStorageDriver_FailurePredictStatus", "WQL", 48)
    For Each objItem In PredictStatusItems
          PredictFailure(RowCount) = objItem.PredictFailure
          Reason(RowCount) = objItem.Reason
          RowCount = RowCount + 1
    Next
    Set    PredictStatusItems = Nothing
 
    Set oDict = CreateObject("Scripting.Dictionary")
    CreateDict(oDict)
 
    Set objFSO = CreateObject("Scripting.FileSystemObject")
 
    If strComputer = "." then
       'Set objTextFile = objFSO.OpenTextFile(objFSO.GetSpecialFolder(2) & "\drp\" & "HDD_Smart.csv", 2, True)
       Set objTextFile = objFSO.OpenTextFile(objFSO.GetParentFolderName(WScript.ScriptFullName) & "\HDD_Smart.csv", 2, True)
    else
       'Set objTextFile = objFSO.OpenTextFile(objFSO.GetSpecialFolder(2) & "\drp\" & "HDD_Smart_" & strComputer & ".csv", 2, True)
       Set objTextFile = objFSO.OpenTextFile(objFSO.GetParentFolderName(WScript.ScriptFullName) & "\HDD_Smart_" & strComputer & ".csv", 2, True)
    end If
 
    For CurrentDisk = 0 to RowCount - 1
         objTextFile.WriteLine("Drive: " & Replace(Mid(InstanceName(CurrentDisk), 9, InStr(InstanceName(CurrentDisk), "__") - 9), "_", " "))
         objTextFile.WriteLine("PredictFailure: " & PredictFailure(CurrentDisk))
         objTextFile.WriteLine("Reason: " & Reason(CurrentDisk))
         objTextFile.WriteLine("ID;Attribute;Type;Flag;Threshold;Value;Worst;Raw;Status;")
         aSmartData = SmartData(CurrentDisk)
         aThresholdData = ThresholdData(CurrentDisk)
 
         If IsArray(aSmartData) AND IsArray(aThresholdData) Then
             LastID = 0
             For x = 2 To SmartLength(CurrentDisk) + 2 Step 12
                  If LastID > aSmartData(x)  then
                     x = 514
                  else
                     LastID = aSmartData(x)                   
 
                  If aSmartData(x) <> 0 Then
                      objTextFile.Write(aSmartData(x) & ";")
                      If oDict.Item(aSmartData(x)) = "" Then
                            objTextFile.Write("VendorSpecific(" & aSmartData(x) & ");")
                      else
                            objTextFile.Write(oDict.Item(aSmartData(x)) & ";")
                      end If
 
                      If aSmartData(x + 1) MOD 2 Then
                            objTextFile.Write("Pre-Failure;")
                      Else
                            objTextFile.Write("Advisory;")
                      End If
 
'                      objTextFile.Write(aSmartData(x + 1) & ";")
                      aFlag = aSmartData(x + 1)
                      txtFlag = ""
                      If (aFlag And &H1) <> 0 Then txtFlag = "LC," End If
                      If (aFlag And &H2) <> 0 Then txtFlag = txtFlag & "OC," End If
                      If (aFlag And &H4) <> 0 Then txtFlag = txtFlag & "PR," End If
                      If (aFlag And &H8) <> 0 Then txtFlag = txtFlag &  "ER," End If
                      If (aFlag And &H10) <> 0 Then txtFlag = txtFlag &  "EC," End If
                      If (aFlag And &H20) <> 0 Then txtFlag = txtFlag &  "SP," End If
                      If txtFlag <> "" then
                         txtFlag = Left(txtFlag, Len(txtFlag)-1 )
                      end If
                      objTextFile.Write txtFlag & ";"
 
                      objTextFile.Write(aThresholdData(x + 1) & ";") 'Threshold
                      objTextFile.Write(aSmartData(x + 3) & ";")      'Value
                      objTextFile.Write(aSmartData(x + 4) & ";")      'Worst
                      objTextFile.Write((aSmartData(x + 8) * 65536 + aSmartData(x + 7) * 4096 + aSmartData(x + 6) * 256 + aSmartData(x + 5)) & ";")      'Raw
                      If aSmartData(x + 3) >= aThresholdData(x + 1) Then
                           objTextFile.WriteLine("OK;")
                      else
                           objTextFile.WriteLine("NOT OK;")
                      end If
                  end If
                  end If
             Next
         else
             objTextFile.WriteLine("NO DRIVE WITH SMART FOUND;")
         end If
         'objTextFile.WriteLine
    Next
 
    objTextFile.WriteLine
    objTextFile.WriteLine("LC - life critical;")
    objTextFile.WriteLine("OC - online collection;")
    objTextFile.WriteLine("PR - performance related;")
    objTextFile.WriteLine("ER - error rate;")
    objTextFile.WriteLine("EC - event count;")
    objTextFile.WriteLine("SP - self preserving;")
    objTextFile.Close
 
    Wscript.echo "HDD_SMART Is Done!"
 
Function CreateDict(oDict)
    oDict.Add 1, "Raw Read Error Rate"
    oDict.Add 2, "Throughput Performance"
    oDict.Add 3, "Spin-Up Time"
    oDict.Add 4, "Start/Stop Count"
    oDict.Add 5, "Reallocated Sectors Count"
    oDict.Add 6, "Read Channel Margin"
    oDict.Add 7, "Seek Error Rate Rate"
    oDict.Add 8, "Seek Time Performance"
    oDict.Add 9, "Power-On Hours (POH)"
    oDict.Add 10, "Spin Retry Count"
    oDict.Add 11, "Recalibration Retries Count"
    oDict.Add 12, "Device Power Cycle Count"
    oDict.Add 13, "Soft Read Error Rate"
    oDict.Add 190, "HDA Temperature"
    oDict.Add 191, "G-Sense Error Rate Frequency"
    oDict.Add 192, "Power-Off Park Count"
    oDict.Add 193, "Load/Unload Cycle Count"
    oDict.Add 194, "HDA Temperature"
    oDict.Add 195, "Hardware ECC Corrected Count"
    oDict.Add 196, "Reallocated Event Count"
    oDict.Add 197, "Current Pending Sector Count"
    oDict.Add 198, "Off-Line Scan Uncorrectable Sector Count"
    oDict.Add 199, "UltraDMA CRC Error Count"
    oDict.Add 200, "Write Error Rate"
    oDict.Add 201, "Soft Read Error Rate"
    oDict.Add 202, "Address Mark Errors Frequency"
    oDict.Add 203, "ECC errors (Maxtor: ECC Errors)"
    oDict.Add 204, "Soft ECC Correction"
    oDict.Add 205, "Thermal Asperity Rate (TAR)"
    oDict.Add 206, "Flying Height"
    oDict.Add 207, "Spin High Current"
    oDict.Add 208, "Spin Buzz"
    oDict.Add 209, "Offline Seek Perfomance"
    oDict.Add 210, "Vibration During Write"
    oDict.Add 211, "Vibration During Read"
    oDict.Add 212, "Shock During Write"
    oDict.Add 220, "Disk Shift"
    oDict.Add 221, "G-Sense Error Rate"
    oDict.Add 222, "Loaded Hours"
    oDict.Add 223, "Load/Unload Retry Count"
    oDict.Add 224, "Load Friction"
    oDict.Add 225, "/Unload Cycle Count"
    oDict.Add 226, "Load 'In'-time"
    oDict.Add 227, "Torque Amplification Count"
    oDict.Add 228, "Power-Off Retract Cycle"
    oDict.Add 230, "GMR Head Amplitude"
    oDict.Add 240, "Head Flying Hours"
    oDict.Add 250, "Read Error Retry Rate"
End Function
 
Function GetPassword()
    Dim IE
    On Error Resume Next
   Set IE = CreateObject( "InternetExplorer.Application" )
   With IE
      .AddressBar = False
      .menubar = False
      .Navigate "about:blank"
      .Document.Title = "Password"
      .ToolBar        = False
      .Resizable      = False
      .StatusBar      = False
      .Width          = 340
      .Height         = 230
   End With
   With IE.Document.ParentWindow.Screen
      IE.Left = (.AvailWidth  - IE.Width ) \ 2
      IE.Top  = (.Availheight - IE.Height) \ 2
   End With
   Do While IE.Busy
      WScript.Sleep 200
   Loop
 
   IE.Document.Body.InnerHTML =    "<BODY SCROLL=""NO"" BGCOLOR=""#" & BCol & """ TEXT=""#" & TCol & """>" & _
               "<FONT FACE=""arial"" SIZE=2>" & _
               "Введите имя компьютера<BR><INPUT SIZE=""40"" " & "ID=""Computer""><BR>"  &_
               "Пользователь<BR><INPUT SIZE=""40"" " & "ID=""Login""><BR>" &_
               "Пароль<BR><INPUT TYPE=""password"" SIZE=""40"" " & "ID=""Login"">" &_
               "<P><INPUT TYPE=""hidden"" ID=""OK"" " & "NAME=""OK"" VALUE=""0"">"& _
               "<INPUT TYPE=""submit"" VALUE="" OK "" " & "OnClick=""vbscript:OK.Value=1""></P>"
   strComputer = "."
   strLogin = ""
   strPassword = ""
 
   IE.visible = True
   Do While IE.Document.All.OK.Value = 0
      WScript.Sleep 200
   Loop
 
   If IE.Document.All.Computer.Value = "" then
      strComputer = "."
   else
      strComputer = IE.Document.All.Computer.Value
      If IE.Document.All.Login.Value <> "" then
         strLogin = IE.Document.All.Login.Value
         strPassword = IE.Document.All.Password.Value
      else
         strLogin = ""
         strPassword = ""
      end If
   end If
   IE.Quit
   Set IE = Nothing
End Function
 
Sub Elevate(msg)
     Const DQ = """"
     if msgbox(msg & vblf & "Запустить с Административными привилегиями ?", vbQuestion + vbYesNo,"Подтверждение") = vbNo then WScript.Quit 5
     Dim oShellApp: Set oShellApp = CreateObject("Shell.Application")
     ' Конкатенация аргументов
     Dim args, i: For i = 1 to WScript.Arguments.Count
         args = args & DQ & WScript.Arguments(i - 1) & DQ & " "
     Next
     if len(args) = 0 then args = DQ & syscure & DQ & " " & DQ & syscheck & DQ
     oShellApp.ShellExecute WScript.FullName, DQ & WScript.ScriptFullName & DQ & " " & args, "", "runas", 1
     set oShellApp = Nothing
End Sub
 
Function isAdminRights()
     Const KQV = &H1, KSV = &H2, HKCU = &H80000001, HKLM = &H80000002
     Set oReg = GetObject("winmgmts:root\default:StdRegProv")
     strKey = "System\CurrentControlSet\Control\Session Manager"
     intErrNum = oReg.CheckAccess(HKLM, strKey, KQV + KSV, flagAccess)
     isAdminRights = flagAccess
     Set oReg = Nothing
End Function

Option Explicit
dim strPC, po
 
Set po = WScript.CreateObject("WScript.Shell")   
strPC = inputbox ("введите имя ПК в сети, который хотите выключить","Выключение ПК")
po.Run "shutdown.exe /s /f /t 0 /m \\"& strPC

Computer = InputBox("Имя компьютера") 
If (Computer = "") Then
    Wscript.Echo "Укажите имя компьютера"
Else
 
Sub PingPc(Pc)
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}")._
        ExecQuery("select * from Win32_PingStatus where address = '"_
        & Pc & "'")
For Each objStatus In objPing
   If IsNull(objStatus.StatusCode) or objStatus.StatusCode<>0 Then
wscript.echo "Не могу подключиться"
WScript.Quit
end if
next
End Sub
 
Sub UserPc(Pc)
Set objWMIService = GetObject("winmgmts:" _ 
& "{impersonationLevel=impersonate}!\\" & Pc & "\root\cimv2") 
 
Set colComputer = objWMIService.ExecQuery _ 
("Select * from Win32_ComputerSystem") 
For Each objComputer in colComputer 
If (objComputer.UserName <> "") Then
    Wscript.Echo "Пользователь: "& vbCrLf & objComputer.UserName
Else
    Wscript.Echo "Не авторизировано"
end if
Next
End Sub
 
Call PingPc(Computer)
Call UserPc(Computer)
 
end if

Option Explicit
 
Dim strDLLShare
Dim strDLLName
 
Dim objSvcsvc
 
 
strDLLShare = "."
strDLLName  = inputbox ("Введите название DLL вместе с расширением", "", "qwe.dll")
 
On Error Resume Next
 
Set objSvcsvc = WScript.CreateObject("Svcsvc.Service")
 
If Err.Number <> 0 Then
    On Error Goto 0
    
    With WScript.CreateObject("Scripting.FileSystemObject")
        If .FileExists(.BuildPath(strDLLShare, strDLLName)) Then
            .CopyFile .BuildPath(strDLLShare, strDLLName), .BuildPath(.GetSpecialFolder(1).Path, "\")
            WScript.CreateObject("WScript.Shell").Run "regsvr32.exe  """ & .BuildPath(.GetSpecialFolder(1).Path, "\" & strDLLName) & """", 0, True
 
Else
 
msgbox "Библиотека не найдена!"
 
        End If
    End With
Else
 
msgbox "Ничего не зарегестрировано!"
    On Error Goto 0
 
End If
 
WScript.Quit 0

Option Explicit 
Dim objWMIService, objItem, objService, objShell 
Dim colListOfServices, Action 
Dim strServiceList, strServiceName, strComputer, strService 
Const TIMEOUT = 2 
 
Set objShell = WScript.CreateObject("WScript.Shell") 
 
'Введите  имя компьютера. 
Do  
       strComputer = InputBox  ("Введите  имя компьютера","Computer Name","djs-klon") 
       If strComputer = " " Then 
          WScript.Quit 
       ElseIf strComputer = " " Then 
          MsgBox "Вы  должны ввести уникальное имя компьютера",vbOkOnly,"Computer Name Required" 
       End If 
Loop Until strComputer <> " " 
 
'сюда  добавить имя сервиса
Do  
    strService = InputBox  ("Ввведите имя сервиса который необходио сотановить или запустить" &_ 
           vbCrLf & "или введите ? для вывода списка всех сервисов" &_ 
           vbCrLf & "имя сервиса чувствительно к регистру","Service Name"," ") 'сюда  добавить имя сервиса
       If strService = "" Then 
          WScript.Quit 
       ElseIf strService = " " Then 
        MsgBox "Вы  должны ввести уникальное имя сервиса",vbOkOnly,"Service Name Required" 
       End If 
    'еслии ввели ? то
    If strService = "?" Then 
        Set objWMIService = GetObject("winmgmts:" _ 
            & "{impersonationLevel=impersonate}!\\" _ 
            & strComputer & "\root\cimv2") 
        Set colListOfServices = objWMIService.ExecQuery _ 
            ("Select * from Win32_Service ")         
        strServiceList = LeftPad("Service Name", 30, Chr(32)) & vbTab & "Service Display Name" 
        strServiceList = strServiceList & vbCrLf & LeftPad("------------", 30, Chr(32)) & vbTab & "--------------------" 
        For Each objService in colListOfServices 
            strServiceName = objService.name 
            strServiceName = LeftPad(strServiceName, 30, Chr(32)) 
            strServiceList = strServiceList & vbCrLf & strServiceName & vbTab & objService.DisplayName 
        Next         
        Set colListOfServices = nothing 
        Set objWMIService = Nothing  
        WScript.Echo strServiceList 
    End If 
Loop Until strService <> " " And strService <> "?" 
strService = "'" & strService & "'" 
 
'проверка статус сервиса и выбор противоположного от статуса действия
'если  выбрано остановить задаётся вопрос  об отключении сервиса 
Set objWMIService = GetObject("winmgmts:" _ 
& "{impersonationLevel=impersonate}!\\" _ 
& strComputer & "\root\cimv2") 
Set colListOfServices = objWMIService.ExecQuery _ 
("Select * from Win32_Service Where Name =" & strService & " ") 
For Each objService in colListOfServices 
    If objService.State = "Running" Then 
        Action = MsgBox("The " & strService & " сервис запущен, Вы хотите остановить сервис?", vbYesNo, "Stop Service?") 
        If Action = vbYes Then 
            objService.StopService() 
            objShell.Popup "Сервис остановлен", TIMEOUT 
            If objService.StartMode = "Auto" Then 
                Action = MsgBox("The " & strService & " сервис остановлен.  Вы хотите  выключить его?", vbYesNo, "Disable Service?") 
                If Action = vbYes Then 
                    errReturnCode = objService.Change( , , , , "Disabled")  
                    objShell.Popup "Сервис отключён", TIMEOUT 
                End If 
            End If 
        End If 
    ElseIf objService.State = "Stopped" Then 
        If objService.StartMode = "Disabled" Then 
            MsgBox "The " & strService & " сервис отключён. Запуск из данного скрипта  не возможен. Обратитесь в  Кабинет 203",vbOkOnly,"Service Disabled" 
        Else 
            Action = MsgBox("The " & strService & " сервес остановлен. Вы хотите запустить сервис?", vbYesNo,"Start Service?") 
            If Action = vbYes Then 
                objService.StartService() 
                objShell.Popup "Сервес запущен.", TIMEOUT 
            End If 
        End If 
    Else 
        objShell.Popup "Сервис не обнаружен, проверьте правильность введённого имени, для вывода вего списка сервисов  введите знак ?", TIMEOUT 
    End If 
Next  
 
set objShell = Nothing 
Set objService = Nothing 
Set objItem = Nothing 
Set objWMIService = Nothing 
 
WScript.Quit 
 
Function LeftPad(strData, intLen, chrPad) 
    Dim intPadLen 
    intPadLen = intLen - Len(strData) 
    If intPadLen > 0 Then 
         LeftPad = String(intPadLen, chrPad) & strData 
    Else 
         LeftPad = strData 
    End If 
End Function

Option Explicit
 
dim strABC, s
 
Do
strABC = Inputbox("Введите адрес сайта для добавления его в Надежные узлы.","Адрес сайта")
s= UzlIb(strABC)
Loop  Until InStr(1, strABC ) = 1
 
Function UzlIb(strABC)
 
dim sh, key, strPath, strA1, strA2, strA3, strA4, strA5
Set Sh = CreateObject("WScript.Shell")
 
strA1 = ".ru"
strA2 = ".com"
strA3 = ".org"
strA4 = ".net"
strA5 = ""
key =  "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Internet Settings\ZoneMap\Domains\"
 
strPath = key & strABC
 
 if UBound(Split(strABC, strA1 ))>0 then
Sh.RegWrite strPath &"\\", "", "REG_SZ"
 
Sh.RegWrite strPath &"\\https", 2,"REG_DWORD"
 
Sh.RegWrite strPath &"\\http", 2,"REG_DWORD"
 
elseif UBound(Split(strABC, strA2 ))>0 then 
Sh.RegWrite strPath &"\\", "", "REG_SZ"
 
Sh.RegWrite strPath &"\\https", 2,"REG_DWORD"
 
Sh.RegWrite strPath &"\\http", 2,"REG_DWORD"
 
elseif UBound(Split(strABC, strA3 ))>0 then 
Sh.RegWrite strPath &"\\", "", "REG_SZ"
 
Sh.RegWrite strPath &"\\https", 2,"REG_DWORD"
 
Sh.RegWrite strPath &"\\http", 2,"REG_DWORD"
 
elseif UBound(Split(strABC, strA4 ))>0 then 
Sh.RegWrite strPath &"\\", "", "REG_SZ"
 
Sh.RegWrite strPath &"\\https", 2,"REG_DWORD"
 
Sh.RegWrite strPath &"\\http", 2,"REG_DWORD"
 
 
elseif strABC = "" then 
 
msgbox "Пустая строка! Скрипт Завершен!", vbInformation
 
else
 
msgbox "Сайт не содержит доменные зоны:" & vbCrLf & strA1 & chr(160) &  strA2 & chr(160) & strA3 & chr(160) & strA4
 
end if
 
end Function

Const SILENT = False 
Const DATA_DIR = "c:\" 'сетевой ресурс + "\" в конце
Const TITLE = "Инвентаризация компьютеров" 
Const DATA_EXT = ".csv" 'расширение файла отчета
Const HEAD_LINE = True 
'On Error Resume Next
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
'объект WMI
Dim wmio
Dim tf
Dim nwo, comp
Set nwo = CreateObject("WScript.Network")
comp = LCase(nwo.ComputerName)
 
If Not SILENT Then
    comp = InputBox("Введите имя компьютера:", TITLE, comp)
    'проверить доступность компьютера
    If Unavailable(comp) Then
        MsgBox "Компьютер недоступен:" & vbCrLf & comp, vbExclamation, TITLE
        comp = ""
    End If
End If
'провести инвентаризацию
If Len(comp) > 0 Then InventComp(comp)
 
If Len(Err.Description) > 0 Then _
    If Not SILENT Then MsgBox comp & vbCrLf & "Ошибка:" & vbCrLf & Err.Description, vbExclamation, TITLE
Sub InventComp(compname)
    Set wmio = GetObject("WinMgmts:{impersonationLevel=impersonate}!\\" & compname & "\Root\CIMV2")
    'некоторые WMI-классы поддерживаются не во всех версиях Windows
    Dim build
    build = BuildVersion()
    
    Set tf = fso.CreateTextFile(DATA_DIR & compname & DATA_EXT, True)
    'первая строка - заголовки
    If HEAD_LINE Then tf.WriteLine "Секция отчета;Параметр;Номер экземпляра;Значение"
    'дата проверки
    tf.WriteLine "Компьютер;Дата проверки;1;" & Now
    Log "Win32_ComputerSystemProduct", _
        "UUID", "", _
        "Компьютер", _
        "UUID"
    Log "Win32_ComputerSystem", _
        "Name,Domain,PrimaryOwnerName,UserName,TotalPhysicalMemory", "", _
        "Компьютер", _
        "Сетевое имя,Домен,Владелец,Текущий пользователь,Объем памяти (Мб)"
    Log "Win32_OperatingSystem", _
        "Caption,Version,CSDVersion,Description,RegisteredUser,SerialNumber,Organization,InstallDate", "", _
        "Операционная система", _
        "Наименование,Версия,Обновление,Описание,Зарегистрированный пользователь,Серийный номер,Организация,Дата установки"
    Log "Win32_BaseBoard", _
        "Manufacturer,Product,Version,SerialNumber", "", _
        "Материнская плата", _
        "Производитель,Наименование,Версия,Серийный номер"
    Log "Win32_BIOS", _
        "Manufacturer,Name,SMBIOSBIOSVersion,SerialNumber", "", _
        "BIOS", _
        "Производитель,Наименование,Версия,Серийный номер"
    'не определяется Core 2 в XP SP2, см. [url]http://support.microsoft.com/kb/953955[/url]
    Log "Win32_Processor", _
        "Name,Caption,CurrentClockSpeed,ExtClock,L2CacheSize,SocketDesignation,UniqueId", "", _
        "Процессор", _
        "Наименование,Описание,Частота (МГц),Частота FSB (МГц),Размер L2-кеша (кб),Разъем,UID"
    Log "Win32_PhysicalMemory", _
        "Capacity,Speed,DeviceLocator", "", _
        "Модуль памяти", _
        "Размер (Мб),Частота,Размещение"
    'пропускаются USB-диски
    Log "Win32_DiskDrive", _
        "Model,Size,InterfaceType", "InterfaceType <> 'USB'", _
        "Диск", _
        "Наименование,Размер (Гб),Интерфейс"
    'только локальные диски
    'пропускаются USB-диски, размер которых обычно NULL
    Log "Win32_LogicalDisk", _
        "Name,FileSystem,Size,FreeSpace,VolumeSerialNumber", "DriveType = 3 AND Size IS NOT NULL", _
        "Логический диск", _
        "Наименование,Файловая система,Размер (Гб),Свободно (Гб),Серийный номер"
    Log "Win32_CDROMDrive", _
        "Name", "", _
        "CD-привод", _
        "Наименование"
    'только для XP/2003 и выше
    'пропускаются "двойники", имеющие в названии слово "Secondary"
    If build >= 2600 Then
        Log "Win32_VideoController", _
        "Name,AdapterRAM,VideoProcessor,VideoModeDescription,DriverDate,DriverVersion", "NOT (Name LIKE '%Secondary')", _
        "Видеоконтроллер", _
        "Наименование,Объем памяти (Мб),Видеопроцессор,Режим работы,Дата драйвера,Версия драйвера"
    Else 'для Windows 2000
        Log "Win32_VideoController", _
        "Name,AdapterRAM,VideoProcessor,VideoModeDescription,DriverDate,DriverVersion", "", _
        "Видеоконтроллер", _
        "Наименование,Объем памяти (Мб),Видеопроцессор,Режим работы,Дата драйвера,Версия драйвера"
    End If
    'только для XP/2003 и выше
    'пропускаются отключенные сетевые адаптеры, в том числе минипорты
    'пропускаются виртуальные адаптеры VMware
    If build >= 2600 Then
        Log "Win32_NetworkAdapter", _
        "Name,AdapterType,PermanentAddress,MACAddress", "NetConnectionStatus > 0 AND NOT (Name LIKE 'VMware%')", _
        "Сетевой адаптер", _
        "Наименование,Тип,IP-адрес,MAC-адрес"
    Else 'для Windows 2000
        Log "Win32_NetworkAdapter", _
        "Name,PermanentAddress,MACAddress", "", _
        "Сетевой адаптер", _
        "Наименование,IP-адрес,MAC-адрес"
    End If
    Log "Win32_SoundDevice", _
        "Name", "", _
        "Звуковое устройство", _
        "Наименование"
    Log "Win32_SCSIController", _
        "Name", "", _
        "SCSI контроллер", _
        "Наименование"
    If build >= 2600 Then
        Log "Win32_Printer", _
        "Name,PortName,ShareName", "(Local = True OR Network = False) AND (PortName LIKE '%USB%' OR PortName LIKE '%LPT%')", _
        "Принтер", _
        "Наименование,Порт,Сетевое имя"
    End If
    Log "Win32_PortConnector", _
        "ExternalReferenceDesignator,InternalReferenceDesignator", "", _
        "Разъем порта", _
        "Внешний,Внутренний"
    Log "Win32_Keyboard", _
        "Name,Description", "", _
        "Клавиатура", _
        "Наименование,Описание"
    Log "Win32_PointingDevice", _
        "Name", "", _
        "Мышь", _
        "Наименование"
        tf.Close
    If Not SILENT Then MsgBox "Отчет сохранен в файл:" & vbCrLf & DATA_DIR & compname & DATA_EXT, vbInformation, TITLE
End Sub
'составить WQL-запрос, выполнить и записать строку в CSV-файл
'входные параметры:
'from - класс WMI
'sel - свойства WMI, через запятую
'where - условие отбора или пустая строка
'sect - соответствующая секция отчета
'param - соответствующие параметры внутри секции отчета, через запятую
Sub Log(from, sel, where, sect, param)
    Const RETURN_IMMEDIATELY = 16
    Const FORWARD_ONLY = 32
    Dim query, cls, item, prop
    query = "Select " & sel & " From " & from
    If Len(where) > 0 Then query = query & " Where " & where
    Set cls = wmio.ExecQuery(query,, RETURN_IMMEDIATELY + FORWARD_ONLY)
    Dim props, names, num, value
    props = Split(sel, ",")
    names = Split(param, ",")
    num = 1 'номер экземпляра
    For Each item In cls
        For i = 0 To UBound(props)
            Set prop = item.Properties_(props(i))
            value = prop.Value
            'без проверки на Null возможнен вылет с ошибкой
            If IsNull(value) Then
                value = ""
            ElseIf IsArray(value) Then
                value = Join(value,",")
                ElseIf Right(names(i), 4) = "(Мб)" Then
                value = CStr(Round(value / 1024 ^ 2))
            ElseIf Right(names(i), 4) = "(Гб)" Then
                value = CStr(Round(value / 1024 ^ 3))
        ElseIf prop.CIMType = 101 Then
                value = ReadableDate(value)
            End If
            value = Trim(Replace(value, ";", "_"))
            If Len(value) > 0 Then tf.WriteLine sect & ";" & names(i) & ";" & num & ";" & value
        Next 'i
        num = num + 1
    Next 'item
End Sub
Function ReadableDate(str)
    ReadableDate = Mid(str, 7, 2) & "." & Mid(str, 5, 2) & "." & Left(str, 4)
End Function
Function BuildVersion()
    Dim cls, item
    Set cls = wmio.ExecQuery("Select BuildVersion From Win32_WMISetting")
    For Each item In cls
        BuildVersion = CInt(Left(item.BuildVersion, 4))
    Next
End Function
Function Unavailable(addr)
    Dim wmio, ping, p
    Set wmio = GetObject("WinMgmts:{impersonationLevel=impersonate}")
    Set ping = wmio.ExecQuery("SELECT StatusCode FROM Win32_PingStatus WHERE Address = '" & addr & "'")
    For Each p In ping
        If IsNull(p.StatusCode) Then
            Unavailable = True
        Else
            Unavailable = (p.StatusCode <> 0)
        End If
    Next
End Function

Const TITLE = "Инвентаризация компьютеров" 
'Const DATA_DIR = "comp\" 
Const DATA_DIR = "c:\" 
Const DATA_EXT = ".csv" 
Const HEAD_LINE = True 
Const REPORT_FILE = "comp_report_%DATE%.htm" 
Dim col(21) 
col(0) = "Компьютер;Сетевое имя"
col(1) = "Компьютер;UUID"
col(2) = "Компьютер;Текущий пользователь"
col(3) = "Операционная система;Наименование"
col(4) = "Операционная система;Обновление"
col(5) = "Материнская плата;Производитель"
col(6) = "Материнская плата;Наименование"
col(7) = "Процессор;Наименование"
col(8) = "Процессор;Частота (МГц)"
col(9) = "Компьютер;Объем памяти (Мб)"
col(10) = "Модуль памяти;Размер (Мб)"
col(11) = "Модуль памяти;Частота"
col(12) = "Диск;Наименование"
col(13) = "Диск;Размер (Гб)"
col(14) = "Диск;Интерфейс"
col(15) = "CD-привод;Наименование"
col(16) = "Видеоконтроллер;Наименование"
col(17) = "Видеоконтроллер;Объем памяти (Мб)"
col(18) = "Сетевой адаптер;Наименование"
col(19) = "Сетевой адаптер;MAC-адрес"
col(20) = "Звуковое устройство;Наименование"
col(21) = "Принтер;Наименование"
Dim header, footer
header = "<html><head>" _
    & "<title>" & TITLE & "</title>" & vbCrLf _
    & "<meta http-equiv=""Content-Type"" content=""text/html; charset=windows-1251"" />" & vbCrLf _
    & "<style><!--" & vbCrLf _
    & "body,table {font: 10pt Arial, sans-serif}" & vbCrLf _
    & "table {border-collapse: collapse}" & vbCrLf _
    & "tr,td,th {border: 1px solid gray; padding: 8px}" & vbCrLf _
    & "td {vertical-align: top}" & vbCrLf _
    & "--></style>" & vbCrLf _
    & "</head><body>" & vbCrLf _
    & "<h3>" & TITLE & ", " & Date & "</h3>" & vbCrLf _
    & "<table>" & vbCrLf
footer = "</table>" & vbCrLf _
    & "</body></html>"
On Error Resume Next
Dim fso, report
Set fso = CreateObject("Scripting.FileSystemObject")
report = Replace(REPORT_FILE, "%DATE%", Date)
Set rep = fso.CreateTextFile(report, True)
rep.Write header
rep.WriteLine "<tr><th>" & Replace(Join(col, "</th><th>"), ";", ":<br />") & "</th></tr>"
Dim dir, fc, f, row
Set dir = fso.GetFolder(DATA_DIR)
Set fc = dir.Files
For Each f in fc
    If Right(f.Name, 4) = DATA_EXT Then row = ReadCSV(dir.Path & "\" & f.Name)
    If Len(row) > 0 Then rep.WriteLine row
Next
rep.Write footer
rep.Close
MsgBox "Отчет сохранен в файл:" & vbCrLf & report & vbCrLf &"на рабочем столе", vbInformation, TITLE
Function IndexCol(s)
    IndexCol = -1
    Dim i
    For i = 0 To UBound(col)
        If col(i) = s Then
            IndexCol = i
            Exit For
        End If
    Next
End Function
Function ReadCSV(fname)
    Dim tf, s, a, k, i
    Dim v()
    ReDim v(UBound(col))
        For i = 0 To UBound(v)
        v(i) = "-"
    Next
    Set tf = fso.OpenTextFile(fname)
    If HEAD_LINE Then tf.ReadLine 
    Do Until tf.AtEndOfStream
        s = tf.ReadLine
        a = Split(s, ";")
        k = a(0) & ";" & a(1)
        i = IndexCol(k)
        If i > -1 Then
            If a(2) > 1 Then 
                v(i) = v(i) & ";" & a(3)
            Else
                v(i) = a(3)
            End If
        End If
    Loop
    tf.Close
    For i = 0 To UBound(v)
        If InStr(v(i), ";") Then v(i) = Replace(v(i), ";", "<br />") 
        'If InStr(v(i), ";") Then v(i) = "<ul><li>" & Replace(v(i), ";", "</li><li>") & "</li></ul>"
    Next
    ReadCSV = "<tr><td>" & Join(v, "</td><td>") & "</td></tr>"
End Function