Получить информацию о видеокарте

Private Sub Command1_Click()
    On Error Resume Next
    Set objService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\CIMV2")
    Set VideoController = objService.ExecQuery("SELECT * FROM Win32_VideoController")
    For Each objVideo In VideoController
        VidInfa$ = objVideo.SystemName 'имя компьютера
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.Caption 'наименование устройства
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.Description  'описание устройства
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.DeviceID  'идентификатор устройства
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.AdapterRAM  'размер памяти видеоадаптера
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.CurrentHorizontalResolution  'текущее разрешение экрана по горизонтали (точек)
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.CurrentVerticalResolution 'текущее разрешение экрана по вертикали (точек)
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.CurrentNumberOfColors  'число цветов в текущем разрешении экрана
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.VideoModeDescription  'текущее разрешение экрана и число цветов
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.CurrentBitsPerPixel  'качество цветопередачи (количество бит на пиксель)
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.CurrentRefreshRate  'частота обновления экрана, Гц
        '(0 - по умолчанию, 0xFFFFFFFF - оптимальная)
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.DriverDate  'дата-время последней модификации текущего видеодрайвера
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.DriverVersion  'версия текущего видеодрайвера
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.PNPDeviceID  'идентификатор устройства Plug-and-Play
        VidInfa$ = VidInfa$ & vbCrLf & objVideo.VideoProcessor  'описание видеопроцессора
    Next
    MsgBox VidInfa$
End Sub

'Используется WMI
'Option Explicit
Dim fso, wmio, nwo, strInform As String
Private Sub Command1_Click()
    strInform = ""
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set nwo = CreateObject("WScript.Network")
    If Len(LCase(nwo.ComputerName)) > 0 Then InformationAboutVideo (LCase(nwo.ComputerName))
    MsgBox strInform, vbInformation, "Видеоадаптер" 'Print strInform' переменная содержит информацию о видеоадаптере
End Sub
Sub InformationAboutVideo(CompName)
    Set wmio = GetObject("WinMgmts:{impersonationLevel=impersonate}!\\" & CompName & "\Root\CIMV2")
        Log "Win32_VideoController", _
        "Name,AdapterRAM,VideoProcessor,VideoModeDescription,DriverDate,DriverVersion", "NOT (Name LIKE '%Secondary')", _
        " ", _
        "Наименование,Объем памяти (Мб),Видеопроцессор,Режим работы,Дата драйвера,Версия драйвера"
End Sub
 
'составить WQL-запрос, выполнить и записать в переменную
'входные параметры:
'from - класс WMI
'sel - свойства WMI, через запятую
'where - условие отбора или пустая строка
'sect - соответствующая секция отчета
'param - соответствующие параметры внутри секции отчета, через запятую
'для отображения в кратных единицах, нужно их указать в скобках
Sub Log(from, sel, where, sect, param)
    Dim i As Integer, query, clss, item, prop
    Const RETURN_IMMEDIATELY = 16, FORWARD_ONLY = 32
    query = "Select " & sel & " From " & from
    If Len(where) > 0 Then query = query & " Where " & where
    Set clss = wmio.ExecQuery(query, , RETURN_IMMEDIATELY + FORWARD_ONLY)
    Dim props, names, value
    props = Split(sel, ",")
    names = Split(param, ",")
    For Each item In clss
        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
                    strInform = strInform & vbCrLf & names(i) & "  -        " & value
             End If
        Next
    Next
End Sub
Function ReadableDate(str)
    ReadableDate = Mid(str, 7, 2) & "." & Mid(str, 5, 2) & "." & Left(str, 4)
End Function