Вывод списка установленных на компьютере приложений (программ) на рабочий лист Excel с помощью кода VBA.
Введение
Список установленных приложений может быть полезен не только в информационном плане для ознакомления с ним, но и для сохранения, например, на флэшку или другой гаджет перед переустановкой операционной системы. После переустановки ОС можно сразу по списку установить необходимые для работы программы.
Ниже размещен пример кода VBA Excel, который использует объекты WMI (Windows Management Instrumentation) для доступа к реестру Windows и получения списка установленных приложений (по данным разделов Uninstall) и вывода их на новый лист в текущей книге Excel.
Код для вывода списка приложений
Код процедуры VBA Excel, выводящей список установленных на компьютере приложений (программ) на рабочий лист:
|
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 |
Sub ListInstalledApps() ' Объявляем переменные Dim objWMIService As Object Dim objReg As Object Dim strUninstallPath As String Dim arrSubKeys As Variant Dim subKey As Variant Dim strDisplayName As String Dim strDisplayVersion As String Dim strPublisher As String Dim ws As Worksheet Dim rowNum As Long Dim HKEY_LOCAL_MACHINE As Long Dim HKEY_CURRENT_USER As Long Dim lRet As Long ' Переменная для кода возврата методов StdRegProv Dim strEntryPath As String ' Константы для корневых разделов реестра HKEY_LOCAL_MACHINE = &H80000002 HKEY_CURRENT_USER = &H80000001 ' Устанавливаем лист для вывода данных On Error Resume Next ' Позволяем коду продолжить, если лист не найден Set ws = ThisWorkbook.Sheets("Установленные программы") On Error GoTo 0 ' Восстанавливаем обработку ошибок по умолчанию If ws Is Nothing Then ' Если лист "Установленные программы" не существует, создаем его Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) ws.Name = "Установленные программы" ' Устанавливаем текстовый формат для столбца с версиями приложений, ' чтобы версии с одной точкой не превращались в числа с запятой ws.Range("B:B").NumberFormat = "@" Else ' Если лист существует, очищаем его ws.Cells.ClearContents ws.Select End If ' Добавляем заголовки столбцов ws.Cells(1, 1).value = "Название приложения" ws.Cells(1, 2).value = "Версия" ws.Cells(1, 3).value = "Издатель" ws.Rows(1).Font.Bold = True ' Начинаем вывод данных со второй строки rowNum = 2 ' --- Получаем объекты WMI --- ' WMI StdRegProv provider позволяет работать с реестром On Error Resume Next ' Обрабатываем возможную ошибку, если WMI недоступен Set objWMIService = GetObject("winmgmts:\\.\root\default") Set objReg = objWMIService.Get("StdRegProv") On Error GoTo 0 ' Восстанавливаем обработку ошибок If objReg Is Nothing Then MsgBox "Не удалось подключиться к WMI или StdRegProv." & vbCrLf & _ "Возможно, WMI отключен или у вас недостаточно прав.", vbCritical Exit Sub End If ' --- Обработка раздела HKEY_LOCAL_MACHINE --- ' Здесь обычно находятся программы, установленные для всех пользователей strUninstallPath = "Software\Microsoft\Windows\CurrentVersion\Uninstall" ' Получаем список подразделов в HKLM\Software\Microsoft\Windows\CurrentVersion\Uninstall lRet = objReg.EnumKey(HKEY_LOCAL_MACHINE, strUninstallPath, arrSubKeys) If lRet = 0 Then ' Код возврата 0 означает успех If Not IsNull(arrSubKeys) Then ' Перебираем каждый подраздел (представляет одно приложение или компонент) For Each subKey In arrSubKeys ' Формируем полный путь к записи приложения в реестре strEntryPath = strUninstallPath & "\" & subKey ' Сбрасываем значения для текущего приложения strDisplayName = "" strDisplayVersion = "" strPublisher = "" ' Читаем значения из реестра (могут отсутствовать) On Error Resume Next ' Игнорируем ошибки, если значение не найдено lRet = objReg.GetStringValue(HKEY_LOCAL_MACHINE, strEntryPath, "DisplayName", strDisplayName) If lRet <> 0 Then strDisplayName = "" ' Если чтение не удалось, оставляем пустым lRet = objReg.GetStringValue(HKEY_LOCAL_MACHINE, strEntryPath, "DisplayVersion", strDisplayVersion) If lRet <> 0 Then strDisplayVersion = "" lRet = objReg.GetStringValue(HKEY_LOCAL_MACHINE, strEntryPath, "Publisher", strPublisher) If lRet <> 0 Then strPublisher = "" On Error GoTo 0 ' Восстанавливаем обработку ошибок ' Выводим информацию на лист, только если найдено название приложения If Trim(strDisplayName) <> "" And Trim(strPublisher) <> "Microsoft Corporation" _ And Trim(strPublisher) <> "NVIDIA Corporation" Then ws.Cells(rowNum, 1).value = strDisplayName ws.Cells(rowNum, 2).value = strDisplayVersion ws.Cells(rowNum, 3).value = strPublisher rowNum = rowNum + 1 End If Next End If Else ' Если EnumKey вернул ошибку (например, нет прав или путь не существует), ' можно проигнорировать или вывести сообщение об ошибке Debug.Print "Ошибка при перечислении ключей HKLM Uninstall: " & lRet End If ' --- Обработка раздела HKEY_LOCAL_MACHINE\Software\WOW6432Node --- ' Этот раздел используется на 64-битных системах для 32-битных приложений strUninstallPath = "Software\WOW6432Node\Microsoft\Windows\CurrentVersion\Uninstall" ' Получаем список подразделов lRet = objReg.EnumKey(HKEY_LOCAL_MACHINE, strUninstallPath, arrSubKeys) ' Проверяем код возврата. Ошибка 0x80070002 (ERROR_FILE_NOT_FOUND) нормальна, если раздела WOW6432Node нет (на 32-битных системах) ' Или просто игнорируем ошибки при перечислении этого раздела If lRet = 0 Then ' Успех If Not IsNull(arrSubKeys) Then For Each subKey In arrSubKeys strEntryPath = strUninstallPath & "\" & subKey strDisplayName = "" strDisplayVersion = "" strPublisher = "" On Error Resume Next lRet = objReg.GetStringValue(HKEY_LOCAL_MACHINE, strEntryPath, "DisplayName", strDisplayName) If lRet <> 0 Then strDisplayName = "" lRet = objReg.GetStringValue(HKEY_LOCAL_MACHINE, strEntryPath, "DisplayVersion", strDisplayVersion) If lRet <> 0 Then strDisplayVersion = "" lRet = objReg.GetStringValue(HKEY_LOCAL_MACHINE, strEntryPath, "Publisher", strPublisher) If lRet <> 0 Then strPublisher = "" On Error GoTo 0 If Trim(strDisplayName) <> "" And Trim(strPublisher) <> "Microsoft Corporation" _ And Trim(strPublisher) <> "NVIDIA Corporation" Then ws.Cells(rowNum, 1).value = strDisplayName ws.Cells(rowNum, 2).value = strDisplayVersion ws.Cells(rowNum, 3).value = strPublisher rowNum = rowNum + 1 End If Next End If Else ' Ошибка при перечислении. Это нормально, если раздела WOW6432Node нет. Debug.Print "Ошибка при перечислении ключей HKLM WOW6432Node Uninstall: " & lRet End If ' --- Обработка раздела HKEY_CURRENT_USER --- ' Здесь обычно находятся программы, установленные только для текущего пользователя strUninstallPath = "Software\Microsoft\Windows\CurrentVersion\Uninstall" ' Получаем список подразделов в HKCU\Software\Microsoft\Windows\CurrentVersion\Uninstall lRet = objReg.EnumKey(HKEY_CURRENT_USER, strUninstallPath, arrSubKeys) If lRet = 0 Then ' Успех If Not IsNull(arrSubKeys) Then For Each subKey In arrSubKeys strEntryPath = strUninstallPath & "\" & subKey strDisplayName = "" strDisplayVersion = "" strPublisher = "" On Error Resume Next lRet = objReg.GetStringValue(HKEY_CURRENT_USER, strEntryPath, "DisplayName", strDisplayName) If lRet <> 0 Then strDisplayName = "" lRet = objReg.GetStringValue(HKEY_CURRENT_USER, strEntryPath, "DisplayVersion", strDisplayVersion) If lRet <> 0 Then strDisplayVersion = "" lRet = objReg.GetStringValue(HKEY_CURRENT_USER, strEntryPath, "Publisher", strPublisher) If lRet <> 0 Then strPublisher = "" On Error GoTo 0 If Trim(strDisplayName) <> "" And Trim(strPublisher) <> "Microsoft Corporation" _ And Trim(strPublisher) <> "NVIDIA Corporation" Then ws.Cells(rowNum, 1).value = strDisplayName ws.Cells(rowNum, 2).value = strDisplayVersion ws.Cells(rowNum, 3).value = strPublisher rowNum = rowNum + 1 End If Next End If Else ' Ошибка при перечислении ключей HKCU Debug.Print "Ошибка при перечислении ключей HKCU Uninstall: " & lRet End If ' Автонастройка ширины столбцов ws.Columns("A:D").AutoFit ' --- Очистка объектов --- Set objReg = Nothing Set objWMIService = Nothing Set ws = Nothing ' --- Завершение --- MsgBox "Список установленных приложений сформирован на листе ""Установленные программы"".", vbInformation End Sub |
В этом коде я использую условие, которое исключает из списка установленных программ приложения от издателей «Microsoft Corporation» и «NVIDIA Corporation».
Если вы хотите отобразить полный список установленных приложений, замените в 3 местах строки:
|
1 2 |
If Trim(strDisplayName) <> "" And Trim(strPublisher) <> "Microsoft Corporation" _ And Trim(strPublisher) <> "NVIDIA Corporation" Then |
на строку:
|
1 |
If Trim(strDisplayName) <> "" Then |
Результат работы кода:
Как использовать эту процедуру
- Откройте любую книгу Excel с поддержкой макросов.
- Нажмите Alt + F11, чтобы открыть редактор VBA (Visual Basic for Applications).
- В окне «Project — VBAProject» (слева) найдите свою книгу.
- Щелкните правой кнопкой мыши по «VBAProject (ВашаКнига.xlsm)» -> Insert -> Module.
- Вставьте скопированный выше код в окно нового модуля.
- Нажмите Alt + Q или закройте редактор VBA.
- Вернитесь в Excel. Нажмите Alt + F8, чтобы открыть диалоговое окно «Макрос».
- Выберите макрос ListInstalledApps из списка и нажмите кнопку «Выполнить».
Запустить процедуру можно после 5 шага непосредственно из модуля.
Макрос создаст (или очистит, если уже существует) лист с именем «Установленные программы» и заполнит его названиями, версиями и издателями приложений, найденных в соответствующих разделах реестра Windows.
Пояснения к выводу списка программ
- Макрос обращается к реестру через WMI провайдер StdRegProv, который является стандартным способом взаимодействия с реестром из скриптов и программ без прямого использования Windows API.
- Он сканирует два основных раздела реестра: HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Uninstall (для программ, установленных для всех пользователей) и HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Uninstall (для программ, установленных только для текущего пользователя).
- На 64-битных системах также проверяется раздел HKEY_LOCAL_MACHINE\Software\WOW6432Node\Microsoft\Windows\CurrentVersion\Uninstall, который содержит информацию о 32-битных приложениях.
- Для каждой найденной записи в разделе Uninstall скрипт пытается прочитать значения DisplayName, DisplayVersion и Publisher.
- При чтении отдельных значений используется оператор On Error Resume Next, так как не все записи в Uninstall имеют все эти значения.
- На лист Excel выводится только информация о тех записях, у которых есть значение DisplayName (Название приложения), чтобы отфильтровать большинство системных обновлений и компонентов без какого-либо имени.
- Перед заполнением лист очищается, чтобы при повторном запуске макроса не дублировались данные.
Возможные ограничения
- Список может содержать не только полноценные приложения, но и некоторые обновления Windows, компоненты, библиотеки и т.п., которые зарегистрированы в разделе Uninstall.
- Некоторые очень старые или специфические программы могут не регистрироваться стандартным образом в этих разделах реестра.
- Права доступа: для чтения HKLM могут потребоваться права администратора, хотя обычно разделы Uninstall доступны для чтения всем пользователям. Макрос выполняется в контексте текущего пользователя Excel.
- Список может содержать дубликаты, если одна и та же программа зарегистрирована в нескольких разделах (например, и в HKLM, и в HKCU).
Содержание рубрики VBA Excel по тематическим разделам со ссылками на все статьи.