Форум программистов, компьютерный форум, киберфорум
Наши страницы
VBScript/JScript/WSH/WMI/HTA
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг 4.72/505: Рейтинг темы: голосов - 505, средняя оценка - 4.72
Dragokas
Эксперт WindowsАвтор FAQ
16968 / 7053 / 856
Регистрация: 25.12.2011
Сообщений: 10,862
Записей в блоге: 16
#1

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

15.10.2012, 00:41. Просмотров 92108. Ответов 32
Метки нет (Все метки)

В этой теме выкладываем скрипты, которые часто используются Вами
или на Ваш взгляд могут иметь большое практическое значение.

Также приветствуются скрипты высокой степени сложности, полезные с точки зрения
изучения принципа их работы.

Правила темы:
  • При выкладывании скрипта постарайтесь тщательно описывать принцип его работы и по-больше комментировать строки Вашего кода.
  • Если Ваш код очень большой, помещайте его под CUT. Также можно сделать 2 варианта: 1. Чистый код. 2. С комментариями.
  • Запрещаются любые обсуждения выложенных здесь работ;
  • если в этом есть необходимость, создайте отдельную тему в которой опишите замечание или проблему при работе с данным скриптом, указав ссылку на сообщение из этой темы (правый клик по слову "Permalink" вверху каждого сообщения).
  • Если Вы хотите внести исправление в выложенный Вами код - пишите мне в личку ссылку на Ваше старое сообщение и новый исправленный вариант. (полный вариант с тегами Вашего старого сообщения можно получить, нажав на него - кнопка "Цитата").
  • Допускается размещение обзора программ, помогающих редактировать/отлаживать код.

Схожая тема: Полезные макросы, надстройки и шаблоны (VBA)
Смежная тема: Полезные BAT/CMD скрипты


******************* Перечень полезных скриптов: *******************
Отправка файла на FTP (Drag & Drop) и копирование ссылки в буфер обмена ссылка
Получение времени сервера ссылка
5
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
15.10.2012, 00:41
Ответы с готовыми решениями:

Как вызвать скрипты .vbs из .wsf?
Добрый день! Пытаюсь освоить WSH с целью автоматического создания...

VBS, метод POST, заполнение полей и иже с ними
С помощью скрипта лезу на сайт. Далее нужно заполнить поля формы. Тут ступор...

Добавление программы в автозагрузку через скрипт vbs
Доброго врмени суток. Никак не могу найти скрипт vbs добавления в автозагрузку....

Vbs -скрытый запуск программы с параметрами и её отслеживание
Требуется скрыто запускать программу с параметром, если она завершится, скрыто...

Создание бинарного файла из vbs / Как создать exe файл из vbs
Имеется файл с расширением exe. Нужно как-нибудь занести массив байт в скрипт,...

32
Dragokas
Эксперт WindowsАвтор FAQ
16968 / 7053 / 856
Регистрация: 25.12.2011
Сообщений: 10,862
Записей в блоге: 16
15.10.2012, 00:58  [ТС] #2
Отправка файла на FTP (Drag & Drop) и копирование ссылки в буфер обмена

1) Внести в код имя своего FTP-сервера, имя пользователя и пароль, корневую директорию.
1) Сохранить код в файл "FTP and ClipBoard.VBS"
2) Перетащить на него любой файл.

Получаем отправку на FTP и в буфере обмена уже готовую ссылочку.

Есть баг: русские имена файлов отправляются нормально, но ссылку получаем нерабочую.
Пока не знаю как исправить. Если есть идеи, прошу в тему.

Развернуть код ...
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
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
3
Вложения
Тип файла: zip FTP and ClipBoard.zip (1.3 Кб, 469 просмотров)
Smitis
1629 / 338 / 39
Регистрация: 15.10.2012
Сообщений: 529
29.12.2012, 13:25 #3
VRENN.vbs: Переименование файлов с использование регулярных выражений.

Функционал
- Скрипт создавался для запуска из консоли через cscript. Запуск через wscript возможен, но я это не использую и особо не тестировал.
- Расширения файлов не обрабатываются и, соответственно, не изменяются! Это фича.
- Считается, что имена файлов, имеющие в имени единственную точку первым символом, расширения не имеют (например, .htaccess).
- Для папок, в отличии от файлов, расширения не имеют для системы значения, поэтому их имена обрабатываются целиком.
- Расшифровка VRENN:
V - VBS
REN - RENAME
N - Names only
- Регулярные выражения поддерживают все возможности объекта VBScript.RegExp. Справку по синтаксису смотреть в справке по VBS. В случае использования в регулярных выражениях различных специфичных для командной строки символов, например символа ^, следует заключать выражение в кавычки. Также, может понадобится удваивание символа процента и пр.
- Специальный "пустой" именованный параметр / указывает, что шаблон проверяет имя с начала - символ ^ добавляется в начало шаблона автоматически. Сделано для удобства, иногда позволяет не заключать шаблон в кавычки.
- Вместо пустого шаблона замены "" (для удаления части имени) можно указать один символ \. Сделано для удобства.
- Неправильные именованные параметры игнорируются.
- В новом имени отбрасываются начальные и конечные пробелы.
- Переименование отменяется, если новое имя пустое.
- В случае конфликта имён, существующие файлы не переписываются (операция отменяется).
- Скрипт может обрабатывать только файлы (по умолчанию) или только папки (параметр /F) или всё вместе (параметр /FF). В последнем случае сначала обрабатываются папки, потом файлы.
- Рекурсия по папкам не поддерживается.
- Файлы с установленными атрибутами hidden и system по умолчанию не обрабатыватся. Для включения их в обработку служит параметр /H.
- Регистр символов по умолчанию игнорируется. Для включения регистрозависимости в шаблоне, используется параметр /CS (Case Sensifity).
- Производится глобальная замена в имени. Т.е. "vrenn a b" переименует файл aaa.aaa в bbb.aaa. Для отключения глобальной замены служит параметр /1.
- Порядок обработки имён определяется системой (для NTFS это в алфавитном порядке, для других не знаю).
- Перед обработкой сначала формируется список всех файлов/папок, попадающих под обработку. Это позволяет избежать ситуаций, когда после переименования файл опять попадает под условие переименования, файлы пропускаются, так как изменился порядок файлов и т.п.
- Дополнительно, может использоваться фильтр по маске "в стиле ДОС" (вида *.jpg или a?b*c.doc). Может быть несколько масок, перечисленных через точку с запятой (*.jpg;*.bmp;*.gif). Естественно, маска, в отличие от регулярного выражения, затрагивает и расширения. Весь механизм фильтрации возложен на объект Shell.Application
- При использованиия маски, могут быть нюансы, связанные с обработкой файлов проводником, например, архивы zip могут распознаваться как папки, а скрипт будет считать их файлами. Это связано с особенностями использования объекта Shell.Application
- Вместо маски, после символа @, может быть указан файл, содержащий список файлов и папок, подлежащих обработке. Это сделано для использования из FAR Commander-а.
- Скрипт обрабатывает описания файлов, хранящиеся в descript.ion. Кодировка описаний - CP-1251. Обработку описаний можно отключить параметром /Z-. При включеной обработке описаний, файл descript.ion не переименовывается даже если попадает под шаблон.
- Есть режим тестирования (кдюч /t когда только обрабатываются регулярные выражения, а реального переименования не происходит.
- Вместо переименования можно копировать/перемещать файлы в другую папку (параметры /C и /M).
- Для удобства, помимо замены можно добавлять к каждому имени в начало (префикс - параметр /P:text) и в конец (суффикс - параметр /S:text) некоторый заданный текст.


Основные способы применения:

vrenn pattern
- вывод списка

vrenn [mask|@list] pattern /C:folder [options]
- копирование в папку

vrenn [mask|@list] pattern /M:folder [options]
- пемещение в папку

vrenn [mask|@list] pattern replace [/P:text] [/S:text]
- переименование

vrenn [mask|@list] pattern /P:text /S:text
- только добавление текста
3
Вложения
Тип файла: zip vrenn.4.00.zip (5.9 Кб, 367 просмотров)
Казанский
14059 / 5785 / 1507
Регистрация: 24.09.2011
Сообщений: 9,066
06.01.2013, 15:53 #4
Получение ErrorLevel из команды CMD в переменную VBS-скрипта
(на примере команды сравнения файлов)

Visual Basic
1
2
3
4
5
6
7
8
9
Function FileCompare(path1, path2)
    'возвращает результат двоичного сравнения двух файлов
    'с помощью системной утилиты fc.exe. Возвращаемое значение:
    '0 - файлы одинаковы;
    '1 - файлы различаются;
    '2 - файл не найден
FileCompare = CreateObject("wscript.shell").Run( _
    "cmd /c fc /b """ & path1 & """ """ & path2 & """", 0, True)
End Function
Комментарий Dragokas:
Добавлю от себя: чтобы симитировать свой произвольный код возврата, достаточно указать команду Exit <code>
Например,
Visual Basic
'Двоичный сдвиг 0110(6) -> 0011(3)
FileCompare = CreateObject("wscript.shell").Run( _
    "cmd /v:on /c set /A x=6"">>""1& exit !x!", 0, True)
2
Eva Rosalene
T for Trans-
4050 / 1589 / 303
Регистрация: 06.01.2013
Сообщений: 4,179
Завершенные тесты: 2
28.05.2013, 14:44 #5
Шифрование (BAT+VBS)

crypt.vbs
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
if Wscript.Arguments.count < 4 then
 Wscript.Echo "Неверный синтаксис"
 Wscript.Quit
end if
 
if Wscript.Arguments(0) = "crypt" then
 OutLn = Crypt(Wscript.Arguments(1),Wscript.Arguments(2))
else
 if Wscript.Arguments(0) = "decrypt" then
  OutLn = Decrypt(Wscript.Arguments(1),Wscript.Arguments(2))
 else
  Wscript.Echo "Неизвестная функция: " & Wscript.Arguments(0)
 end if
end if
 
Set FSO = CreateObject("Scripting.FileSystemObject")
 
With FSO.OpenTextFile(Wscript.Arguments(3),2, True)
 .Write(OutLn)
 .Close
End With
Wscript.Quit
 
Function Crypt(Source, Key)
 With CreateObject("Scripting.FileSystemObject")
  With .OpenTextFile(Source, 1, False)
   SourceText = .ReadAll
   .Close
  End With
  With .OpenTextFile(Key, 1, False)
   KeyText = .ReadAll
   .Close
  End With
 End With
 Crypt=""
 KeyL = Len(KeyText)
 for i = 1 to Len(SourceText)
  Crypt = Crypt & chr(Circle(Asc(Mid(SourceText, i, 1)),Asc(Mid(KeyText, NumbKT(i,KeyL), 1)),255,0))
 next
End Function
 
Function Decrypt(Crypted, Key)
 With CreateObject("Scripting.FileSystemObject")
  With .OpenTextFile(Crypted, 1, False)
   CrText = .ReadAll
   .Close
  End With
  With .OpenTextFile(Key, 1, False)
   KeyText = .ReadAll
   .Close
  End With
 End With
 Decrypt=""
 KeyL = Len(KeyText)
 for i = 1 to Len(CrText)
  Decrypt = Decrypt & chr(Circle(Asc(Mid(CrText, i, 1)),Asc(Mid(KeyText, NumbKT(i,KeyL), 1)),255,1))
 next
End Function
 
Function NumbKT(position, Length)
 NumbKt = position-Length*(position\Length)
 if NumbKT = 0 then NumbKT = Length
End Function
 
Function Circle(Code1, Code2, Max, Sign)
 if Sign = 1 then Circle = Code1 + Code2
 if Sign = 0 then Circle = Code1 - Code2
 if Circle > Max then Circle = Circle - Max*(Circle\Max)
 if Circle < 1 then Circle = Max + Circle
End Function
crypt.bat
Bash
1
2
3
4
5
@echo off
cscript crypt.vbs %* //NOLOGO
echo.All
pause>nul
exit /b
Вызов:
crypt <crypt> <Исходный файл> <Файл ключа> <Выходной файл>
crypt <decrypt> <Зашифрованный файл> <Файл ключа> <Выходной файл>

Тестировалась только на текстовых файлах, на бинарях работа не гарантируется.
Алгоритм шифрования самый простейший - Цезарь, поэтому на серьезную защиту не надейтесь. Хотя, размер ключа может быть произвольный, вплоть до размера самого файла.

Добавлено через 18 часов 41 минуту
И да, последняя функция (Circle) несколько ошибочна. Скрипт работает, но в теории может все-таки вызвать баги. Надо так:
Visual Basic
1
2
3
4
5
6
Function Circle(Code1, Code2, Max, Sign)
 if Sign = 1 then Circle = Code1 + Code2
 if Sign = 0 then Circle = Code1 - Code2
 if Circle > Max then Circle = Circle - Max*(Circle\Max) - 1
 if Circle < 0 then Circle = Max + Circle +1 
End Function
4
Dmitrii
2603 / 535 / 107
Регистрация: 21.03.2012
Сообщений: 1,043
27.08.2013, 00:53 #6
Установка ключа "Требовать смену пароля при следующем входе в систему" для заданной учётной записи пользователя домена.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
'Установка ключа "Требовать смену пароля при следующем входе в систему"
'для заданной учётной записи пользователя домена.
'Сценарий ориентирован на работу в графическом режиме.
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


Добавлено через 1 минуту
Очистка пароля заданной учётной записи пользователя домена.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
'Очистка пароля заданной учётной записи пользователя домена.
'Сценарий ориентирован на работу в графическом режиме.
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


Добавлено через 1 минуту
Управление настройками пароля для всех членов заданной группы пользователей домена.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
'Управление настройками пароля для всех членов заданной группы пользователей домена:
'- включение|выключение режима "Требовать смену пароля при следующем входе в систему"
'  (атрибут "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


Добавлено через 1 минуту
Определение даты последней регистрации сеанса пользователя в многоконтроллерном домене.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
'Определение даты последней регистрации сеанса пользователя в многоконтроллерном домене
'с возможностью включения|отключения соответствующей учётной записи.
'Сценарий ориентирован на работу в графическом режиме.
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


Добавлено через 3 минуты
Поиск учётных записей пользователей домена, имеющих ограничения в списке станций, на которые им разрешён интерактивный вход.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
'Поиск учётных записей пользователей домена, имеющих ограничения в списке станций,
'на которые им разрешён интерактивный вход.
'Сценарий ориентирован на работу в консольном режиме.
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


Добавлено через 1 минуту
Получение списка всех контроллеров домена с указанием формального уровня их иерархии (основной|дополнительный), наличием роли глобального каталога и распределением FSMO между ними.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
'Получение списка всех контроллеров домена с указанием формального уровня
'их иерархии (основной|дополнительный), наличием роли глобального каталога
'и распределением 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


Добавлено через 1 час 22 минуты
Сопоставление логических томов, назначенных НЖМД и съёмным накопителям, с физическими устройствами.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
'Сопоставление логических томов, назначенных НЖМД и съёмным накопителям, с физическими устройствами.
'Типы съёмных накопителей, на работу с которыми ориентирован сценарий: 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

Небольшое описание вышеприведённого сценария.
Кликните здесь для просмотра всего текста
Алгоритм работы сценария таков:

1. Выбор из списка логических дисков компьютера тех томов, которые размещены на НЖМД и съёмных накопителях (кроме внешних НГМД и НОД).
То есть из всех экземпляров класса Win32_LogicalDisk выбираются те экземпляры, значение свойства DriveType для которых равно 2 (Removable Disk) или 3 (Local Disk).
Visual Basic
1
Set objCollection = objWMI.ExecQuery("SELECT * FROM Win32_LogicalDisk WHERE DriveType=2 OR DriveType=3")
2. Определение для каждого выбранного тома того раздела накопителя, на котором данный том существует.
То есть каждый из выбранных ранее экземпляров класса Win32_LogicalDisk ассоциируется с соответствующим экземпляром класса Win32_DiskPartition.
Ассоциирование выполняется с помощью класса Win32_LogicalDiskToPartition.
Процедура данного ассоциирования состоит из этапов:
- поиск значения свойства DeviceID (буквенное имя тома) экземпляра класса Win32_LogicalDisk в значении свойства Dependent каждого экземпляра класса Win32_LogicalDiskToPartition;
- автоматическое определение значения свойства Antecedent для найденного экземпляра класса Win32_LogicalDiskToPartition, которое одновременно является значением свойства DeviceID (строка, содержащая порядковые номера физического накопителя и нужного из его разделов) экземпляра класса Win32_DiskPartition;
- добавление в коллекцию ссылки на результирующий эклемпляр класса Win32_DiskPartition.
Visual Basic
1
2
3
4
5
6
For Each objLD In objLogicalDisks
     Set objPartitions = objWMI.ExecQuery("ASSOCIATORS OF {Win32_LogicalDisk.DeviceID=""" & _
                            objLD.DeviceID & _
                            """} WHERE AssocClass=Win32_LogicalDiskToPartition")
'...
Next
3. Определение для каждого выбранного раздела того физического накопителя, на котором данный раздел существует.
То есть каждый из выбранных ранее экземпляров класса Win32_DiskPartition ассоциируется с соответствующим экземпляром класса Win32_DiskDrive.
Ассоциирование выполняется с помощью класса Win32_DiskDriveToDiskPartition.
Процедура данного ассоциирования состоит из этапов:
- поиск значения свойства DeviceID экземпляра класса Win32_DiskPartition в значении свойства Dependent каждого экземпляра класса Win32_DiskDriveToDiskPartition;
- автоматическое определение значения свойства Antecedent для найденного экземпляра класса Win32_DiskDriveToDiskPartition, которое одновременно является значением свойства DeviceID (строка, представляющая собой уникальное обозначение физического накопителя) экземпляра класса Win32_DiskDrive;
- добавление в коллекцию ссылки на результирующий эклемпляр класса Win32_DiskDrive.
Visual Basic
1
2
3
4
5
6
For Each objPart In objPartitions
     Set objDrives = objWMI.ExecQuery("ASSOCIATORS OF {Win32_DiskPartition.DeviceID=""" & _
                          objPart.DeviceID & _
                          """} WHERE AssocClass=Win32_DiskDriveToDiskPartition")
     '...
Next
4. Определение для каждого выбранного физического накопителя ряда его системных характеристик.
То есть для каждого из выбранных экземпляров класса Win32_DiskDrive запрашиваются у системы и предъявляются пользователю значения свойств Caption (наименование модели накопителя) Index (порядковый номер накопителя на момент запроса).
Visual Basic
1
2
3
For Each objDrive In objDrives
     strTemp = strTemp & objLD.DeviceID & " => " & objDrive.Caption & " (Диск " & objDrive.Index & ")" & vbNewLine
Next


Добавлено через 3 минуты
Сценарий для показа членам заданной группы пользователей домена текста какого-либо уведомления (например, поздравления по случаю праздника).
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
'Сценарий для показа членам заданной группы пользователей домена
'текста какого-либо уведомления (например, поздравления по случаю праздника).
'Текст уведомления представляет собой заранее созданную 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
3
Dmitrii
2603 / 535 / 107
Регистрация: 21.03.2012
Сообщений: 1,043
29.08.2013, 23:05 #7
Ограничение количества одновременно работающих экземпляров заданного процесса на заданной станции домена.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
'Ограничение количества одновременно работающих экземпляров заданного процесса на заданной станции домена.
'Процесс идентифицируется по имени исполняемого файла, станция - по 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
2
KoGG
5274 / 1347 / 320
Регистрация: 23.12.2010
Сообщений: 2,019
Записей в блоге: 1
30.08.2013, 17:56 #8
Для целей переименовавания музыкальных файлов для воспроизведения в случайном порядке.
Данный скрипт переименовывает все файлы в выбранной папке, присоединяя слева к старому имени файла случайный порядковый номер. Если у файла в имени был слева номер, то старый номер удаляется.
Папка выбирается через файловый диалог Word.

Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
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
3
Dmitrii
2603 / 535 / 107
Регистрация: 21.03.2012
Сообщений: 1,043
30.08.2013, 23:17 #9
Получение ряда сведений (идентификатор, имя, полный путь к исполняемому файлу, владелец, использованная при запуске командная строка) о заданном процессе на заданной станции домена.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
'Получение ряда сведений о заданном процессе на заданной станции домена:
'- идентификатор;
'- имя;
'- полный путь к исполняемому файлу;
'- владелец;
'- командная строка, использованная при запуске.
'Процесс идентифицируется по имени его исполняемого файла.
'Если имя станции не задано, выпоняется опрос текущей станции.
'Если имя процесса не задано, обрабатывается весь список процессов.
'Сценарий ориентирован на работу в графическом режиме.
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


Добавлено через 2 часа 32 минуты
Определение типа сеанса (интерактивный/удалённый) текущего пользователя на текущем узле и внесение данных об интерактивном сеансе в заданном регистрационном каталоге.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
'Определение типа сеанса (интерактивный/удалённый) текущего пользователя на текущем узле
'и внесение данных об интерактивном сеансе в заданном регистрационном каталоге.
'Путь к регистрационному каталогу задаётся в сценарии (значение переменной "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
1
Dragokas
Эксперт WindowsАвтор FAQ
16968 / 7053 / 856
Регистрация: 25.12.2011
Сообщений: 10,862
Записей в блоге: 16
27.02.2014, 03:44  [ТС] #10
GetCPUUsage - Получение % CPU для всех процессов в системе
ver. 1.2

Будет полезно для быстрого детекта bitcoin-майнеров или других "непослушных" процессов.

Показывает такую информацию:
  • % нагрузки на CPU
  • Имя процесса
  • Process ID
  • Связанная служба (псевдоним + описание)
  • Путь к процессу
  • Путь к родительскому процессу
% нагрузки:
- текущая нагрузка при тесте в 2 сек. - в логе ProcessCPU_Current.csv
- средняя нагрузка за все время работы ОС - в логе ProcessCPU_Average.csv

Нагрузка вычисляется по формуле


Дельта времени KernelModeTime + UserModeTime процесса
/
Дельта времени KernelModeTime + UserModeTime системы в целом
* 100

Информация берется из объекта WMI (Win32_Process, Win32_Service)

Инструкция по использованию:

1. Распакуйте архив.
2. Запустите файл GetCPUUsage.vbs
3. Если появится сообщение от User Accaunt Control, отвечаем "Да".
4. Подождите, пока не появится сообщение "Готово."
5. Выложите в теме, где Вам оказывают помощь, файлы:
  • ProcessCPU_Current.csv
  • ProcessCPU_Average.csv
упаковав их в архив формата zip.

Если произошла ошибка, вышлите мне ее скриншот.
Если логи не появились, нажмите левой клавишей мыши по заголовку папки и затем клавишу F5.

код
v.1.2.

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
' GetCPUUsage by Dragokas
' ver. 1.2
'
' Разработано специально для ассоциации VIRUSNET [SafeZone.cc]
 
option explicit
 
dim oFSO, LogFile_full, LogFile_cur, oShell, cur, ver
ver = "1.2"
 
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("WScript.Shell")
 
' Make me Admin :) Получаем права Администратора
if WScript.Arguments.Count = 0 then
    if not isAdminRights() then
        Elevate()
        WScript.Quit
    end if
end if
 
cur = oFSO.GetParentFolderName(WScript.ScriptFullName)
 
LogFile_full = cur & "\ProcessCPU_Average.csv"
LogFile_cur  = cur & "\ProcessCPU_Current.csv"
 
on error resume next
if oFSO.FileExists(LogFile_full) then oFSO.DeleteFile(LogFile_full)
if oFSO.FileExists(LogFile_cur)  then oFSO.DeleteFile(LogFile_cur)
if Err.Number <> 0 then msgbox "Ошибка! Закройте, пожалуйста, книги Excel и запустите скрипт еще раз.", vbCritical, "GetCPUUsage v." & ver & " by Dragokas": WScript.Quit 1
on error goto 0
 
oShell.Popup "Пожалуйста, подождите...", 4, "GetCPUUsage by Dragokas"
 
CPUTimeToLog
msgbox "Готово." & vblf & "Выложите в теме, где Вам оказывают помощь, файлы:" & vblf & vblf &_
    "1. ProcessCPU_Current.csv" & vblf & "2. ProcessCPU_Average.csv" & vblf & vblf &_
    "упаковав в архив формата zip.", vbInformation, "GetCPUUsage v." & ver & " by Dragokas"
WScript.Quit
 
Set oFSO = Nothing: Set oShell = Nothing
 
 
Sub CPUTimeToLog()
    dim Kernel_t1, User_t1, Total_t1
    dim Kernel_t2, User_t2, Total_t2
    dim oSCR_t1, oSCR_t2, oSCR_PID, oSCR_path, oSCR_Serv, oSCR_parentPID, oTS, WMI, oProcesses, oProcess, Key
    dim Proc_t1, Proc_t2, Delta_Proc, Delta_System, oServices, oService, Service_Name, ParentPID, ParentPath
 
    'PID -> TotalTime
    set oSCR_t1 = CreateObject("Scripting.Dictionary")
    set oSCR_t2 = CreateObject("Scripting.Dictionary")
    'PID -> Name
    set oSCR_PID = CreateObject("Scripting.Dictionary")
    'PID -> Путь и параметры командной строки
    set oSCR_path = CreateObject("Scripting.Dictionary")
    'PID -> Service
    set oSCR_Serv = CreateObject("Scripting.Dictionary")
    'PID -> ParentPID
    set oSCR_parentPID = CreateObject("Scripting.Dictionary")
 
    Set WMI = GetObject("winmgmts:\root\cimv2")
 
    Set oServices = WMI.ExecQuery("SELECT * FROM Win32_Service") 'Получаю имена и описания служб -> привязываю к PID (ключ - это PID)
    For each oService in oServices
        if oSCR_Serv.Exists(oService.ProcessID) then
            oSCR_Serv(oService.ProcessID) = oSCR_Serv(oService.ProcessID) & _
                oService.Name & " (" & oService.Caption & "), "
        else
            oSCR_Serv.Add oService.ProcessID, oService.Name & " (" & oService.Caption & "), "
        end if
    Next
 
    WScript.Sleep(500) ' Нормализация % скачка CPU, вызванного запуском этого скрипта
 
    ' 1-я засечка
    Set oProcesses = WMI.ExecQuery("SELECT * FROM Win32_Process")
    For each oProcess in oProcesses
        with oProcess
            Kernel_t1 = Kernel_t1 + cdbl(.KernelModeTime)
            User_t1   = User_t1   + cdbl(.UserModeTime)
            oSCR_t1.Add        .ProcessID, cdbl(.KernelModeTime) + cdbl(.UserModeTime)
            oSCR_PID.Add       .ProcessID, .Caption             'PID -> Name
            oSCR_path.Add      .ProcessID, .ExecutablePath      'PID -> Path
            oSCR_parentPID.Add .ProcessID, .ParentProcessId     'PID -> ParentPID
        end with
    Next
    'Всего времени всех процессов
    Total_t1 = Kernel_t1 + User_t1
 
    set oTS = oFSO.CreateTextFile(LogFile_full, true)
    oTS.WriteLine "CPU (%);Process Name;PID;Service;Path;ParentPath"
 
    SpecialSortDict oSCR_t1, true 'Сортировка словаря в обратном порядке по % CPU.
    
    For each Key in oSCR_t1.Keys
        Proc_t1 = oScr_t1(Key)
        if (oSCR_Serv.Exists(Key) and Key <> 0) then Service_Name = oSCR_Serv(Key) else Service_Name = ""
        ParentPID = oSCR_parentPID(Key)
        if (oSCR_path.Exists(ParentPID) and Key <> 0) then ParentPath = oSCR_path(ParentPID) else ParentPath = ""
        oTS.Write round(Proc_t1 / Total_t1 * 100, 2) & ";"      'CPU (%)
        oTS.Write oSCR_PID(Key) & ";"                           'Process Name
        oTS.Write Key & ";"                                     'PID
        oTS.Write Service_Name & ";"                            'Service
        oTS.Write oScr_path(Key) & ";"                          'Path
        oTS.Write ParentPath & ";"                              'Parent Path
        oTS.WriteLine ""
    Next
    oTS.Close
 
    WScript.Sleep(2000) 'выжидаю 2 сек.
 
    ' 2-я засечка
    Set oProcesses = WMI.ExecQuery("SELECT * FROM Win32_Process")
    For each oProcess in oProcesses
        with oProcess
            Kernel_t2 = Kernel_t2 + cdbl(.KernelModeTime)
            User_t2   = User_t2   + cdbl(.UserModeTime)
            oSCR_t2.Add .ProcessID, cdbl(.KernelModeTime) + cdbl(.UserModeTime)
            if not oSCR_PID.Exists(.ProcessID) then
                oSCR_PID.Add       .ProcessID, .Caption             'PID -> Name (если появились новые)
                oSCR_path.Add      .ProcessID, .ExecutablePath      'PID -> Path (если появились новые)
                oSCR_parentPID.Add .ProcessID, .ParentProcessId     'PID -> ParentPID
            end if
        end with
    Next
    'Всего времени всех процессов
    Total_t2 = Kernel_t2 + User_t2
 
    ' Словарь PID -> Дельта CPU:
    ' Записываю разницу по формуле:
    ' % нагрузки процесса = Дельта времени процесса / дельта времени системы * 100
    Dim oSCR_delta: set oSCR_delta = CreateObject("Scripting.Dictionary")
    For each Key in oSCR_t2.Keys
        Proc_t1 = oScr_t1(Key)
        Proc_t2 = oScr_t2(Key)
        Delta_Proc   = Proc_t2  - Proc_t1
        Delta_System = Total_t2 - Total_t1
        oSCR_delta.Add key, round(Delta_Proc / Delta_System * 100, 2)
    Next
 
    SpecialSortDict oSCR_delta, true ' Сортировка словаря в обратном порядке по % CPU.
 
    set oTS = oFSO.CreateTextFile(LogFile_cur, true)
    oTS.WriteLine "CPU (%);Process Name;PID;Service;Path;ParentPath"
 
    For each Key in oSCR_delta.Keys
        if (oSCR_Serv.Exists(Key) and Key <> 0) then Service_Name = oSCR_Serv(Key) else Service_Name = ""
        ParentPID = oSCR_parentPID(Key)
        if (oSCR_path.Exists(ParentPID) and Key <> 0) then ParentPath = oSCR_path(ParentPID) else ParentPath = ""
        oTS.Write oSCR_delta(key) & ";"                                 'CPU (%)
        oTS.Write oSCR_PID(Key) & ";"                                   'Process Name
        oTS.Write Key & ";"                                             'PID
        oTS.Write Service_Name & ";"                                    'Service
        oTS.Write oScr_path(Key) & ";"                                  'Path
        oTS.Write ParentPath & ";"                                      'ParentPath
        oTS.WriteLine ""
    Next
    oTS.Close
 
    Set oProcess = Nothing: set oProcesses = Nothing: set WMI = Nothing: set oTS = Nothing
    Set oSCR_PID = Nothing: set oSCR_t1 = Nothing: set oSCR_t2 = Nothing: set oSCR_path = Nothing
    Set oSCR_Serv = Nothing: set oSCR_parentPID = Nothing
End Sub
 
 
Sub Elevate()
    Dim colOS, oOS, strOSLong, oShellApp
    Const DQ = """"
    Set colOS = GetObject("winmgmts:\root\cimv2").ExecQuery("Select * from Win32_OperatingSystem")
    For Each oOS In colOS: strOSLong = oOS.Version: Next
    If Left(strOSLong, 1) = "6" and Not isAdminRights Then
        Set oShellApp = CreateObject("Shell.Application")
        oShellApp.ShellExecute WScript.FullName, DQ & WScript.ScriptFullName & DQ & " " & DQ & "Twice" & DQ, "", "runas", 1
        WScript.Quit
    End If
    set oOS = Nothing: set colOS = Nothing: set oShellApp = Nothing
End Sub
 
Function isAdminRights()
    Dim oReg, strKey, intErrNum, flagAccess
    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
 
'Сортировка словаря методом вставок -> исходный словарь реконструируется
Sub SpecialSortDict(inDict, Reverse)
    Dim arrPos: arrPos = inDict.keys                    'Инициализация массива позиций ключей словаря
    Dim arrTemp: arrTemp = inDict.Items                 'Виртуализация значений словаря
 
    Dim i, j, xItem
    For i = 1 To UBound(arrTemp)                        'Сортировка методом вставок
        For j = i To 1 Step -1
            If arrTemp(j) < arrTemp(j - 1) Then
                xItem = arrTemp(j)                      'Обмен значений
                arrTemp(j) = arrTemp(j - 1)
                arrTemp(j - 1) = xItem
                xItem = arrPos(j)                       'Обмен ключей
                arrPos(j) = arrPos(j - 1)
                arrPos(j - 1) = xItem
            Else
                Exit For
            End If
        Next
    Next
 
    dim iStart, iEnd, iStep
    if Reverse then iStep = -1: iStart = UBound(arrPos): iEnd = 0 else iStep = 1: iStart = 0: iEnd = UBound(arrPos)
 
    Dim virtDict: Set virtDict = CreateObject("Scripting.Dictionary")   
    For i = iStart To iEnd step iStep                         'Расставляем значения в виртуальный словарь согласно массива ключей
        virtDict.Add arrPos(i), inDict(arrPos(i))
    Next
 
    Set inDict = virtDict
End Sub



v.1.1

Кликните здесь для просмотра всего текста

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
' GetCPUUsage by Dragokas
' ver. 1.1
'
' Разработано специально для ассоциации VIRUSNET [SafeZone.cc]
 
option explicit
 
dim oFSO, LogFile_full, LogFile_cur, oShell, cur, ver
ver = "1.1"
 
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("WScript.Shell")
 
' Make me Admin :) Получаем права Администратора
if WScript.Arguments.Count = 0 then
    if not isAdminRights() then
        Elevate()
        WScript.Quit
    end if
end if
 
cur = oFSO.GetParentFolderName(WScript.ScriptFullName)
 
LogFile_full = cur & "\ProcessCPU_Average.csv"
LogFile_cur  = cur & "\ProcessCPU_Current.csv"
if oFSO.FileExists(LogFile_full) then oFSO.DeleteFile(LogFile_full)
if oFSO.FileExists(LogFile_cur)  then oFSO.DeleteFile(LogFile_cur)
 
CPUTimeToLog
msgbox "Готово." & vblf & "Выложите в теме, где Вам оказывают помощь, файлы:" & vblf & vblf &_
    "1. ProcessCPU_Current.csv" & vblf & "2. ProcessCPU_Average.csv" & vblf & vblf &_
    "упаковав в архив формата zip.", vbInformation, "GetCPUUsage v." & ver & " by Dragokas"
WScript.Quit
 
Set oFSO = Nothing: Set oShell = Nothing
 
 
Sub CPUTimeToLog()
    dim Kernel_t1, User_t1, Total_t1
    dim Kernel_t2, User_t2, Total_t2
    dim oSCR_t1, oSCR_t2, oSCR_PID, oSCR_path, oSCR_Serv, oSCR_parentPID, oTS, WMI, oProcesses, oProcess, Key
    dim Proc_t1, Proc_t2, Delta_Proc, Delta_System, oServices, oService, Service_Name, ParentPID, ParentPath
 
    'PID -> TotalTime
    set oSCR_t1 = CreateObject("Scripting.Dictionary")
    set oSCR_t2 = CreateObject("Scripting.Dictionary")
    'PID -> Name
    set oSCR_PID = CreateObject("Scripting.Dictionary")
    'PID -> Путь и параметры командной строки
    set oSCR_path = CreateObject("Scripting.Dictionary")
    'PID -> Service
    set oSCR_Serv = CreateObject("Scripting.Dictionary")
    'PID <-> ParentPID
    set oSCR_parentPID = CreateObject("Scripting.Dictionary")
 
    Set WMI = GetObject("winmgmts:\root\cimv2")
 
    Set oServices = WMI.ExecQuery("SELECT * FROM Win32_Service")
    For each oService in oServices
        if oSCR_Serv.Exists(oService.ProcessID) then
            oSCR_Serv(oService.ProcessID) = oSCR_Serv(oService.ProcessID) & _
                oService.Name & " (" & oService.Caption & "), "
        else
            oSCR_Serv.Add oService.ProcessID, oService.Name & " (" & oService.Caption & "), "
        end if
    Next
 
    WScript.Sleep(500) ' Нормализация % скачка, вызванного этим скриптом
 
    ' 1-я засечка
    Set oProcesses = WMI.ExecQuery("SELECT * FROM Win32_Process")
    For each oProcess in oProcesses
        with oProcess
            Kernel_t1 = Kernel_t1 + cdbl(.KernelModeTime)
            User_t1   = User_t1   + cdbl(.UserModeTime)
            oSCR_t1.Add        .ProcessID, cdbl(.KernelModeTime) + cdbl(.UserModeTime)
            oSCR_PID.Add       .ProcessID, .Caption         'PID <-> Name
            oSCR_path.Add      .ProcessID, .ExecutablePath  'PID <-> Path
            oSCR_parentPID.Add .ProcessID, .ParentProcessId 'PID <-> ParentPID
        end with
    Next
    'Всего времени всех процессов
    Total_t1 = Kernel_t1 + User_t1
 
    set oTS = oFSO.CreateTextFile(LogFile_full, true)
    oTS.WriteLine "Process Name;PID;CPU Time;CPU (%);Service;ParentPath;Path"
    
    For each Key in oSCR_t1.Keys 'Process Name, PID, CPU Time, CPU (%), Path, Service
        Proc_t1 = oScr_t1(Key)
        if (oSCR_Serv.Exists(Key) and Key <> 0) then Service_Name = oSCR_Serv(Key) else Service_Name = ""
        ParentPID = oSCR_parentPID(Key)
        if (oSCR_path.Exists(ParentPID) and Key <> 0) then ParentPath = oSCR_path(ParentPID) else ParentPath = ""
        oTS.WriteLine oSCR_PID(Key) & ";" &_
            Key & ";" &_
            Proc_t1 & ";" &_
            round(Proc_t1 / Total_t1 * 100, 2) & ";" &_
            Service_Name & ";" &_
            ParentPath & ";" &_
            oScr_path(Key)
    Next
    oTS.Close
 
    WScript.Sleep(2000) 'выжидаю 2 сек.
 
    ' 2-я засечка
    Set oProcesses = WMI.ExecQuery("SELECT * FROM Win32_Process")
    For each oProcess in oProcesses
        with oProcess
            Kernel_t2 = Kernel_t2 + cdbl(.KernelModeTime)
            User_t2   = User_t2   + cdbl(.UserModeTime)
            oSCR_t2.Add .ProcessID, cdbl(.KernelModeTime) + cdbl(.UserModeTime)
            if not oSCR_PID.Exists(.ProcessID) then
                oSCR_PID.Add       .ProcessID, .Caption         'PID <-> Name (если появились новые)
                oSCR_path.Add      .ProcessID, .ExecutablePath  'PID <-> Path (если появились новые)
                oSCR_parentPID.Add .ProcessID, .ParentProcessId 'PID <-> ParentPID
            end if
        end with
    Next
    'Всего времени всех процессов
    Total_t2 = Kernel_t2 + User_t2
 
    set oTS = oFSO.CreateTextFile(LogFile_cur, true)
    oTS.WriteLine "Process Name;PID;CPU Time;CPU (%);Service;ParentPath;Path"
 
    ' Записываю разницу по формуле:
    ' % нагрузки процесса = Дельта времени процесса / дельта времени системы * 100
    For each Key in oSCR_t2.Keys 'Process Name, PID, CPU Time, CPU (%), Path, Service
        Proc_t1 = oScr_t1(Key)
        Proc_t2 = oScr_t2(Key)
        Delta_Proc   = Proc_t2  - Proc_t1
        Delta_System = Total_t2 - Total_t1
        if (oSCR_Serv.Exists(Key) and Key <> 0) then Service_Name = oSCR_Serv(Key) else Service_Name = ""
        ParentPID = oSCR_parentPID(Key)
        if (oSCR_path.Exists(ParentPID) and Key <> 0) then ParentPath = oSCR_path(ParentPID) else ParentPath = ""
        oTS.WriteLine oSCR_PID(Key) & ";" &_
            Key & ";" &_
            Proc_t2 - Proc_t1 & ";" &_
            round(Delta_Proc / Delta_System * 100, 2) & ";" &_
            Service_Name & ";" &_
            ParentPath & ";" &_
            oScr_path(Key)
    Next
    oTS.Close
 
    Set oProcess = Nothing: set oProcesses = Nothing: set WMI = Nothing: set oTS = Nothing
    Set oSCR_PID = Nothing: set oSCR_t1 = Nothing: set oSCR_t2 = Nothing: set oSCR_path = Nothing
    Set oSCR_Serv = Nothing: set oSCR_parentPID = Nothing
End Sub
 
 
Sub Elevate()
    Dim colOS, oOS, strOSLong, oShellApp
    Const DQ = """"
    Set colOS = GetObject("winmgmts:\root\cimv2").ExecQuery("Select * from Win32_OperatingSystem")
    For Each oOS In colOS: strOSLong = oOS.Version: Next
    If Left(strOSLong, 1) = "6" and Not isAdminRights Then
        Set oShellApp = CreateObject("Shell.Application")
        oShellApp.ShellExecute WScript.FullName, DQ & WScript.ScriptFullName & DQ & " " & DQ & "Twice" & DQ, "", "runas", 1
        WScript.Quit
    End If
    set oOS = Nothing: set colOS = Nothing: set oShellApp = Nothing
End Sub
 
Function isAdminRights()
    Dim oReg, strKey, intErrNum, flagAccess
    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



История версий

v.1.1.
Добавлен Parent Process Path.

v.1.2.
Сортировка по % CPU в убывающем порядке
Первым столбцом теперь идет % CPU
Убрал отчет о CPU Time
Вывод ошибки, если отчет заблокирован другой программой
3
Вложения
Тип файла: zip GetCPUUsage.zip (2.9 Кб, 196 просмотров)
Dragokas
Эксперт WindowsАвтор FAQ
16968 / 7053 / 856
Регистрация: 25.12.2011
Сообщений: 10,862
Записей в блоге: 16
21.03.2014, 21:10  [ТС] #11
Батник для регистрации DynamicWrapperX 2.0 (x32, x64) и вызова функций из 32/64-битных библиотек.

В комплект уже включена DynamicWrapperX ver.2.0.0.1,
а также демо-VBS, показывающий как свернуть и развернуть "Калькулятор Windows" с помощью API-функций.

FindWindow.vbs - демо-проект (если библиотека не будет зарегистрирована, то сам вызовет regdynwrapx.bat и перезапустится)
regdynwrapx.bat - чтобы зарегистрировать
unregdynwrapx.bat - чтобы снять регистрацию.

Скрипт сам запрашивает права Администратора, если понадобится.
Если Вы хотите вызывать функции из своей 32-битной библиотеки (независимо от битности ОС), раскомментируйте участок кода FindWindow.vbs в строках №№ 16-24.

Если появится новая версия библиотеки DynamicWrapperX, ее папки "32" и "64" нужно скопировать в папку "dynwrapx", заменив оригинал.


О библиотеке DynamicWrapperX

Автор: Юрий Попов (YMP).
Условия распространения библиотеки: freeware.

DynamicWrapperX - это компонент ActiveX, который вы можете использовать в скриптах (JScript, VBScript и т.п.) для вызова:
  • функций из библиотек DLL (в частности функций Windows API);
  • вообще любых функций, адрес которых в памяти вам известен;
  • функций, чей машинный код (в виде хекс-строки) у вас имеется.
Компонент написан с нуля на языке ассемблера GoAsm как попытка более полной реализации идеи DynamicWrapper.

Другие возможности:
  • обратный вызов (callback) скриптовой функции из вызванной вами внешней функции;
  • прямой доступ к памяти (чтение и запись числа по адресу);
  • выделение и освобождение памяти;
  • чтение и запись строк в произвольной кодировке;
  • получение указателя на строку, объект, массив, переменную;
  • получение объекта по указателю на него;
  • определение битности (32 или 64) процесса, в котором выполняется скрипт.
_______________________________

Пример создания пользовательской структуры + получение адреса переменной.
4
Вложения
Тип файла: zip DynWrapReg.zip (48.1 Кб, 209 просмотров)
Dragokas
Эксперт WindowsАвтор FAQ
16968 / 7053 / 856
Регистрация: 25.12.2011
Сообщений: 10,862
Записей в блоге: 16
12.04.2014, 02:30  [ТС] #12
Получение HDD Smart

Автор: Леонид_33

Отчет в виде CSV.
Мною добавлены функции повышение привилегий и скорректирован вывод отчета в папку рядом со скриптом.

Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
'==========================================================================
'
' 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
1
Вложения
Тип файла: zip GetSmart.zip (3.9 Кб, 165 просмотров)
Dragokas
Эксперт WindowsАвтор FAQ
16968 / 7053 / 856
Регистрация: 25.12.2011
Сообщений: 10,862
Записей в блоге: 16
15.07.2014, 13:48  [ТС] #13
Изменение иконки у папки
0
Смолевич
94 / 53 / 5
Регистрация: 19.07.2014
Сообщений: 416
07.08.2014, 00:56 #14
Как VBS упаковать в EXE?

Наваял простенький, очень простенький упаковщик VBS в EXE.
Упаковщик BAT/CMD/JS/VBS в EXE "Script2Bin 1.0.0.0"
Получается EXE весом от 7 КБ.
Пусть пока и не сравнится с серьезными аналогами вроде http://www.vbsedit.com/ зато очень простой, легкий и с интерфейсом по-русски.

Добровольцы могут протестировать и, если понравится, пользоваться...
Может со временем добавлю новых фич, если будет, скажем так, пользоваться спросом...
4
Dragokas
Эксперт WindowsАвтор FAQ
16968 / 7053 / 856
Регистрация: 25.12.2011
Сообщений: 10,862
Записей в блоге: 16
24.08.2014, 23:46  [ТС] #15
RegJump MOD
Переход по комбинации клавиш в ветку реестра Windows, имя которой скопировано в буфер

Позволяет быстро перейти к параметру или разделу реестра, путь к которому скопирован в буфер обмена.

Изначально программа базировалась на утилите от М. Руссиновича RegJump,
но та не поддерживает русские символы. Решил обойтись родными решениями.

Примеры допустимых форматов и сокращений имен:

1) Сокращения ульев (HKLM, HKCU, HKCR, HKU)
2) [раздел реестра] (формат REG-файлов / логов RSIT, SITLog)
3) "раздел реестра"
4) Многострочные данные (раздел реестра будет найден в одной из строк)
5) формат INI-файлов (в т.ч. формат AVZ html лога)
6) Игнорирование лишних слов перед (после) имени раздела.
7) Логи HijackThis, MBAM, ComboFix

Например:
HKLM\System\Setup
"HKLM\System\Setup"
[HKLM\System\Setup]
HKLM, "System\Setup",,

Установка:
Распаковать архив.
Запустить файл RegJump Mod (Установщик).vbs
Для удобства, назначьте комбинацию горячих клавиш для вызова ярлыка, например Ctrl + Shift + Q.

Использование:
Скопировать имя подраздела или параметра реестра в буфер (или кусок текста с таким разделом).

Затем на выбор:

1) Нажать комбинацию клавиш, которую Вы назначили на ярлык;
2) Нажать правым кликом мыши по любому файлу -> Отправить -> "Реестр - прыжок из буфера"
3) Ярлык также доступен по нажатию Shift + правая клавиша мыши по папке или рабочему столу.

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


Совместимость: Windows XP / Vista / 7 / 8 / 8.1
2
Вложения
Тип файла: zip RegJump Mod 2.11.zip (53.3 Кб, 31 просмотров)
Mehonchegg
30 / 12 / 4
Регистрация: 08.05.2013
Сообщений: 83
02.10.2014, 14:19 #16
Еще раз доброго времени суток всем. Хочу поделиться своими скриптами VBS, которые использую для своей работы.
К слову я сисадмин и часто пользуюсь VBS. Возможно некоторые скрипты будут не очень полезны так как их действия легко реализовать через ГПО, но тем не менее мне удобнее использовать скрипт. плюс некоторые легче кому то реализовать в CMD, но тем не менее мне нравится VBS

Кликните здесь для просмотра всего текста
1.Удаленное выключение ПК - очень простой скрипт, но очень полезный в моей работе
Visual Basic
1
2
3
4
5
6
Option Explicit
dim strPC, po
 
Set po = WScript.CreateObject("WScript.Shell")   
strPC = inputbox ("введите имя ПК в сети, который хотите выключить","Выключение ПК")
po.Run "shutdown.exe /s /f /t 0 /m \\"& strPC


Кликните здесь для просмотра всего текста
Проверка ПК на доступность, возвращение имени подключенного пользователя
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
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

Кликните здесь для просмотра всего текста
Регистрация библиотек
Кладем библиотеку рядом со скриптом, запускаем, вводим имя библиотеки с расширением и нажимаем ОК.
Думаю можно переделать чтоб регистрировал все библиотеки рядом со скриптом или из списка.
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
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

Кликните здесь для просмотра всего текста
Запуск_остановка служб на удаленном ПК

Запускаем, вводим имя ПК в сети, вводи название службы: если есть служба проверяет запущена или нет и предлагает запустить или остановить. При вводе знака ? выводит на экран все службы на удаленном ПК (выводит неудобно, в боксе, может кто посмотрит и подскажет как сделать вывод в файл например)
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
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

Кликните здесь для просмотра всего текста
Добавление сайта в надежные узлы
Очень полезен в моей работе так как много приходит мануалов из москвы по которым необходимо что либо настроить пользователям. Вот для удобства сделал себе такой скрипт - ненужно запускать или завершать IE - все происходит через реестр. (Вариаций на эту тему очень много, например есть у меня так же готовый скрипт автоматически настраивающий параметры прокси и надежные узлы и блокировку всплывающих окон и параметры интрасети одним нажатием. Использую его при установке нового ПК. Дополню тем что по сути можно настроить это через ГПО - но опять же для оперативности пользуюсь скриптом)
Собственно скрипт - запускаем вводим сайт (добавил проверку ввели ли вы доменную зону чтоб всякого в реестр не поподало) жмем окей. Скрипт будет продолжаться пока не нажмете отмену ну или пока строка не будет пустая собственно что и возвращает кнопка ОТМЕНА
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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


Если будет появляться у меня что нибудь полезное - обязательно выложу сюда.
3
Mehonchegg
30 / 12 / 4
Регистрация: 08.05.2013
Сообщений: 83
02.10.2014, 20:59 #17
Добавлю пожалуй еще один скрипт
Добавление сетевого принтера.
Visual Basic
1
2
3
4
5
6
7
8
9
10
Option Explicit
Dim WshNetwork
 
 
dim  strPrinterPath 
 
strPrinterPath = InputBox("Введите полный сетевой путь принтера, " & vbCrLf & " который хотите установить на данный ПК"& vbCrLf &"(БЕЗ ПРОБЕЛОВ!!)", "Путь к принтеру", "\\ServerName\PrinterName")
 
Set WshNetwork = WScript.CreateObject("WScript.Network")
WshNetwork.AddWindowsPrinterConnection(strPrinterPath)
Скрипт можно изменить например задать несколько строковых переменных содержащих в себе адреса сетевых принтеров. У меня на работе например таких принтеров 3 - они общие и пользуются ими все, изменил скрипт удалив INPUTBOX и просто расшарил по ГПО пользователи включили ПК и все все три принтера у них имеются. Скажем для удобства на будущее дабы не удалять его из ГПО можно в скрипт добавить проверку существования добавляемого принтера.

Добавлено через 34 минуты
Еще пару скриптов
Собственно скрипт 1.vbs запрашивает имя компа (по умолчанию возвращает имя ПК на котором он запустился), далее создает запрос WQL и дальше с помощью класса и свойств WMI возвращаются, сохраняясь в файл *.csv основные параметры вашего ПК - скажем такая мини инвенторизация. В скрипте я указал где можно и как прописать путь для сохранения файла CSV
Второй скрипт (2.vbs) преобразует файл CSV из первого скрипта в HTML при открытии которого в браузере достаточно удобно выводится вся собранная информация об указанном ПК
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
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
1
Mehonchegg
30 / 12 / 4
Регистрация: 08.05.2013
Сообщений: 83
02.10.2014, 20:59 #18
Скрипт 2.vbs
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
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
3
Sergzh
14 / 1 / 0
Регистрация: 20.06.2015
Сообщений: 19
28.06.2015, 14:28 #19
Может кому-то пригодится.
Этот скрипт превращает любой текстовый редактор (Notepad, Notepad++ и др.) в более комфортную среду разработки.
Также, позволяет бесплатно и легально использовать VbsEdit.

Смысл такой:
Висит постоянно диалог запуска (как бы кнопка Run).
При нажатии, скрипт пользователя сохраняется и стартует, отлавливается ошибка и курсор передвигается на строку с ошибкой.
Видео обзор:
https://www.youtube.com/watch?v=47s7L_CX6VQ

Пример для обычного блокнота:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
'### VBS_Starter.vbs ###
'Алгоритм при нажатии кнопки "старт":
'- Активировать окно редактора
'- Послать сочетание клавишь для сохранения файла
'- Запустить редактируемый скрипт пользователя при помощи cscript
'- Получить лог ошибок
'- Вывести сообщение об ошибке
'- Послать в редактор клавиши перемещения в строку с ошибкой
 
 
'получение админских прав, если их нет (скопипастил, автору спасибо)
If WScript.Arguments.length =0 Then
  Set objShell = CreateObject("Shell.Application")
  'Pass a bogus argument with leading blank space, say [ uac]
  objShell.ShellExecute "wscript.exe", Chr(34) & _
  WScript.ScriptFullName & Chr(34) & " uac", "", "runas", 1
Else
'теперь права есть
 
Set fso = CreateObject("Scripting.FileSystemObject")
Set shell = WScript.CreateObject("WScript.Shell")
 
'смена текущего каталога
shell.CurrentDirectory=fso.GetParentFolderName(Wscript.ScriptFullName)
 
'все ли файлы есть для работы
'project.vbs - это файл пользователя
If Not fso.FileExists("project.vbs") Then
    Set f = fso.CreateTextFile ("project.vbs",True)
    f.WriteLine ("'Test file")
    f.WriteLine ("x=10")
    f.WriteLine ("y=20")
    f.WriteLine ("z=?/(y-y)")
    For c=0 To 100
        f.WriteLine ("")
    Next
    f.WriteLine ("z=y/(x-x)")
    f.Close
End If 
 
shell.Run "notepad project.vbs"
 
'перенаправить вывод cscript в файл получилось только из cmd, увы...
If Not fso.FileExists("run.cmd") Then
    Set f = fso.CreateTextFile ("run.cmd",True)
    f.WriteLine ("CScript project.vbs //U 2>>err.log")
    f.Close
End If 
 
'главный цикл
do
    'Popup не замораживает окно редактора
    res=shell.Popup("Запустить project.vbs?",0,"VBS_Starter",vbOkCancel)
    If res=1 Then 
            'активация окна project.vbs
            shell.AppActivate "project.vbs"
            WScript.Sleep (100)
            
            'это последовательность кнопок для сохранения файла в Notepad
            'как послать Ctrl+S я не понял...
            shell.SendKeys "%"
            WScript.Sleep (100)
            For cc=1 To 3
                shell.SendKeys "{DOWN}"
                WScript.Sleep (100)
            Next
            shell.SendKeys "{ENTER}"
 
    
        'удаляем старый лог ошибок
        If fso.FileExists("err.log") then
            Set f = fso.GetFile("err.log")
            f.Delete
        End If
 
            'запускаем project.vbs с помощью cmd
            shell.Run "run.cmd",0, True
        
            If fso.FileExists("err.log") Then   'лог есть
                Set f=fso.GetFile("err.log")    
                If f.Size > 0 Then              'не пустой, значит в project.vbs есть ошибка
                        
                        'читаем лог
                        Set ts = fso.OpenTextFile("err.log",1,-1,-1)
                        s = ts.ReadLine
                        ts.Close
                        'получить номер строки с ошибкой
                        ar = Split(s,"(")
                        ar2 = Split (ar(1),",")
                        ar3 = Split (s,")")
                        ns = ar2(0)
                            
                            'идем в окно project.vbs
                            shell.AppActivate "project.vbs"
                            WScript.Sleep (100)
 
                            'курсор в самое начало
                            'ВНИМАНИЕ, для других редакторов будет другая !!!
                            shell.SendKeys "^{HOME}"
                            WScript.Sleep (100)
                            shell.AppActivate "project.vbs"
                            WScript.Sleep (100)
                                                        
                            'двигаем курсор до ошибки
                            For c=1 To ns-1
                                shell.SendKeys "{DOWN}"
                                WScript.Sleep (1)
                            Next
                                WScript.Sleep (100) 
                                For c=1 To 2
                                    shell.SendKeys "{TAB}"
                                    WScript.Sleep (500)
                                    shell.SendKeys "{BACKSPACE}"
                                    WScript.Sleep (500)
                                Next
                                'сообщаем об ошибке
                                shell.Popup "(" + ar(1),0,"VBS_Starter",16
                                WScript.Sleep (100)
                                'далее все повторяется
                Else 
                        MsgBox "Ваш скрипт успешно завершен.",0,"VBS_Starter"
                End If
            End If
    Else
        'удаляем старый лог ошибок
        If fso.FileExists("err.log") then
            Set f = fso.GetFile("err.log")
            f.Delete
        End If
        'удаляем cmd, для красоты
        If fso.FileExists("run.cmd") then
            Set f = fso.GetFile("run.cmd")
            f.Delete
        End If  
                            'закрываем редактор
                            shell.AppActivate "project.vbs"
                            WScript.Sleep (100)
                            shell.SendKeys "%{F4}"
                            WScript.Sleep (100)                                     
        WScript.Quit        
    End if 
Loop
 
End If
п.с : Путь до папки с проектом не должен содержать символов "(" и ")" иначе может номер строки с ошибкой не правильно распарситься.
1
greg zakharov
Покинул форум
1947 / 823 / 236
Регистрация: 07.05.2015
Сообщений: 1,645
22.09.2015, 20:24 #20
Пара стареньких vbs'ок, написанных некогда мной для расширения кругозора.
Аналог утилиты strings от SysInternals:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
On Error Resume Next
Err.Clear
 
Dim args : Set args = WScript.Arguments
Dim pars : Set pars = args.Named
Dim anon : Set anon = args.Unnamed
Dim rexp : Set rexp = New RegExp
 
Dim len, buf, str, enc, ofs, mat, m
 
If args.Count < 1 Then
  WScript.Echo WScript.ScriptName & " v1.0 - search strings in file"
  WScript.Echo "Copyright (C) 2015 greg zakharov" & vbCrLf
  WScript.Echo "Usage: " & WScript.ScriptName & " [/b][/n][/o][/u][/p:<file>]"
  WScript.Echo "  /b - bytes of file to scan"
  WScript.Echo "  /n - minimum string length (default is 3)"
  WScript.Echo "  /o - print offset in file string was located"
  WScript.Echo "  /u - unicode-only search"
  WScript.Quit 1
End If
 
Sub Except()
  If Err.Number <> 0 Then
    WScript.Echo "Error: 0x" & Hex(Err.Number)
    WScript.Quit 1
  End If
End Sub
 
With CreateObject("Scripting.FileSystemObject")
  If Not .FileExists(anon(0)) Then
    WScript.Echo "File not found or does not exist."
    WScript.Quit 1
  End If
  
  anon = .GetAbsolutePathName(anon(0)) 'required for SpFileStream
  len = .GetFile(anon).Size
End With
 
'bytes to process
If pars.Exists("B") Then
  If CInt(pars.Item("B")) > len Then
    WScript.Echo "Out of range."
    WScript.Quit 1
  End If
  
  len = CInt(pars.Item("B"))
End If
 
With CreateObject("SAPI.SpFileStream")
  .Open anon, 0
  Except() 'error opening file
  .Read buf, len
  .Close
End With
 
'string length
If pars.Exists("N") Then
  str = CInt(pars.Item("N"))
Else
  str = 3
End If
 
'encoding
If pars.Exists("U") Then
  Set enc = CreateObject("System.Text.UnicodeEncoding")
Else
  Set enc = CreateObject("System.Text.UTF7Encoding")
End If
 
'offsets condition
If pars.Exists("O") Then
  ofs = True
End If
 
'looking for strings
rexp.Pattern = "[\x20-\x7E]{" & CStr(str) & ",}"
rexp.Global = True
rexp.IgnoreCase = True
 
Set mat = rexp.Execute(enc.GetString((buf)))
For Each m In mat
  If ofs Then
    WScript.Echo m.FirstIndex & ": " & m
  Else
    WScript.Echo m
  End If
Next
Вычисление md5 файла:
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
On Error Resume Next
 
Dim args : Set args = WScript.Arguments
Dim arg, len, buf, raw, res
 
Sub Exception()
  If Err.Number <> 0 Then
    WScript.Echo "Error: 0x" & Hex(Err.Number)
    Err.Clear
    WScript.Quit Err.Number
  End If
End Sub
 
If args.Count <> 1 Then
  WScript.Echo "Index is out of range."
  WScript.Quit 1
End If
 
arg = args.Unnamed(0)
With CreateObject("Scripting.FileSystemObject")
  If Not .FileExists(arg) Then
    WScript.Echo "File not found or does not exist."
    WScript.Quit 1
  End If
  
  len = .GetFile(arg).Size
  arg = .GetAbsolutePathName(arg)
End With
 
With CreateObject("SAPI.spFileStream")
  .Open arg, 0
  Exception()
  .Read buf, len
  .Close
End With
 
With CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
  Exception()
  raw = .ComputeHash_2((buf))
  For i = 1 To LenB(raw)
    res = res & Right("0" & Hex(AscB(MidB(raw, i, 1))), 2)
  Next
  
  WScript.Echo LCase(res)
End With
2
22.09.2015, 20:24
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
22.09.2015, 20:24

Вывод сообщений из программы сценария VBScript (.vbs-файл)
Дано: Win2003Srv До переустановки системы сценарий VBScript выводил сообщения...

Полезные PowerShell скрипты
Здесь публикуются полезные с практической точки зрения сценарии PowerShell или...

Полезные BAT/CMD скрипты
В этой теме выкладываем скрипты, которые часто используются Вами или на Ваш...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
20
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.
Рейтинг@Mail.ru