Sub TestSerialNumUSB()
    Dim k
    For Each k In USBGetCur
        Debug.Print k
    Next
End Sub


'функция извлечения информация о текущих флешках, возвращает двухмерный массив
'1-я размерность: серийный номер, наименование, объем, VID и PID
'2-я размерность: счетчик
Function USBGetCur()
    On Error Resume Next
    Dim wmiDiskDrive, wmiDiskDrives    'диски
    Dim wmiUSBHub, wmiUSBHubs    'USB
    Dim PnPID, PnPID2    'идентификатор флешки
    Dim USBSNumb    'серийный номер
    Dim arrUSBInfo()    'массив для информации о каждой флешке
    Dim i    'счетчик
    'переменные для 2-го способа извлечения VID-PID
    Dim strComputer    'местный компьютер
    Dim strValueName    'название параметра
    Dim strKeyPath    'раздел с информацией об USB
    Dim objReg    'реестр
    Dim subkey, arrSubKeys, arrSubKeys1    'подключ и массивы подразделов
    Dim ParIdPre    ' переменная для параметра ParentIdPrefix
    Const HKLM = &H80000002
    Set wmiDiskDrives = GetObject("winmgmts:").InstancesOf("Win32_DiskDrive")    'получаем диски
    Set wmiUSBHubs = GetObject("winmgmts:").InstancesOf("Win32_USBHub")    'получаем USB
    'значения для 2-го способа извлечения VID-PID
    strComputer = "."    'местный компьютер"
    strValueName = "ParentIdPrefix"    'название параметра"
    strKeyPath = "SYSTEM\CurrentControlSet\Enum\USB"    'раздел с информацией об USB
    Set objReg = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv")    'получаем провайдера реестра
    i = 0
    For Each wmiDiskDrive In wmiDiskDrives    'побежали по дискам
        If wmiDiskDrive.InterfaceType = "USB" Then    'если диск USB
            ReDim Preserve arrUSBInfo(4, i)    'перебили размерность массива
            arrUSBInfo(1, i) = wmiDiskDrive.Model    'модель диска
            arrUSBInfo(2, i) = wmiDiskDrive.Size    'объем диска
            PnPID = wmiDiskDrive.PnPDeviceID    'идентификатор флешки из реестра
            'вытаскиваем серийный номер флешки
            USBSNumb = Mid(PnPID, InStrRev(PnPID, " \ ") + 1)    'выбираем из строки-идентификатора серийник
            arrUSBInfo(0, i) = Left(USBSNumb, Len(USBSNumb) - 2)    'удаляем последние 2 символа — типа &0 или &1
            For Each wmiUSBHub In wmiUSBHubs    'побежали по USB
                PnPID2 = wmiUSBHub.PnPDeviceID
                'вытаскиваем серийник и сравниваем с серийником из Win32_DiskDrive
                If Right(PnPID2, Len(PnPID2) - InStr(5, PnPID2, "\")) = arrUSBInfo(0, i) Then
                    arrUSBInfo(3, i) = Mid(PnPID2, 9, 4)    'вытаскиваем VID
                    arrUSBInfo(4, i) = Mid(PnPID2, 18, 4)    'вытаскиваем PID
                    Exit For
                End If
            Next
            If IsEmpty(arrUSBInfo(3, i)) Then    'если не прокатило получить VID, тогда попробуем 2-й способ — через реестр
                objReg.EnumKey HKLM, strKeyPath, arrSubKeys    'получаем подразделы
                If IsArray(arrSubKeys) Then    'на всякий случай — если массив
                    For Each subkey In arrSubKeys    'для каждого подраздела
                        If Left(subkey, 3) = "Vid" Then    'если название раздела начинается с Vid — пропускаем ROOT_HUB и пр.
                            objReg.EnumKey HKLM, strKeyPath & " \ " & subkey, arrSubKeys1    'получаем подразделы подразделов"
                            If IsArray(arrSubKeys1) Then    'снова если массив
                                For Each subsubkey In arrSubKeys1    'для каждого подраздела подразделов
                                    'получаем значение параметра ParentIdPrefix
                                    objReg.GetStringValue HKLM, strKeyPath & " \ " & subkey & " \ " & subsubkey, strValueName, ParIdPre
                                    'поднимем в верхний регистр ParentIdPrefix и сравним с серийным номером
                                    If UCase(ParIdPre) = USBSNumb Then
                                        arrUSBInfo(3, i) = Mid(subkey, 5, 4)    'вытаскиваем из строки VID и PID
                                        arrUSBInfo(4, i) = Mid(subkey, 14, 4)
                                    End If
                                Next
                            End If
                        End If
                    Next
                End If
            End If
            i = i + 1
        End If
    Next
    If i <> 0 Then
        USBGetCur = arrUSBInfo    'если есть флешки
    Else
        USBGetCur = i
    End If
End Function