Обнаружить все жесткие диски на компе

Environ("SystemDrive")

Dim fso, drv
Set fso = CreateObject("Scripting.FileSystemObject")
For Each drv In fso.Drives
  If drv.DriveType = 2 Then Debug.Print drv.DriveLetter
Next drv

Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Sub Drv_List()
    DrvList$ = "ABCDEFGHIJKLMNOPQRTSUVWXYZ"
    For i% = 1 To 26
        Root$ = Mid$(DrvList$, i%, 1) + ":\"
        If GetDriveType(Root$) = 3 Then Debug.Print Root$; " - æåñòêèé äèñê"
    Next i%
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_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-привод", _
        "Наименование"
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

Function DrivesAccess$()
Dim DiskName&
On Error Resume Next
 
For DiskName = Asc("A") To Asc("Z")
 
    If Len(Dir$(Chr$(DiskName) & ":", vbDirectory)) = 0 Then
        Rem 'эта ветвь выполняется всегда при ошибке
    Else
        DrivesAccess = DrivesAccess + Chr$(DiskName) + ","
    End If
Next
DrivesAccess = Left$(DrivesAccess, Len(DrivesAccess) - 1)
End Function

For i% = Asc("A") To Asc("Z")
        Root$ = Chr$(i%) + ":\"