Option Explicit
 
Sub PrüfeUSBGerät()
'
'   Code vom 23.03.2007 / EtoP, Hansueli Göldi [ohne Gewähr für irgendwas... 
' ;-)]
'
    Dim strDevName As String
    strDevName = InputBox("Geben Sie den Namen (oder einen Teil)" & vbCrLf & _
                          "des zu suchenden Gerätes an:", "USB Geräte suchen", _
                          "*ListAllUSBDevices*")
    If strDevName = "" Then Exit Sub
    If checkUSBDevice(strDevName) Then
        MsgBox "Das Gerät ist angeschlossen", vbOKOnly + vbInformation, "USB" & _
          "Check"
    Else
        If strDevName <> "*ListAllUSBDevices*" Then _
            MsgBox "Das Gerät ist NICHT angeschlossen", vbOKOnly + _
            vbExclamation, "USB Check"
    End If
End Sub
 
 
Public Function checkUSBDevice(strUSBDeviceName As String) As Boolean
    Dim objWMIService As Object
    Dim objDevice As Object
    Dim objUSBDevice As Object
    Dim arrDeviceNames As Variant
    Dim colUSBDevices As Variant
    Dim colDevices As Variant
    Dim strDevicename As String
 
    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
    Set colDevices = objWMIService.ExecQuery _
        ("Select * From Win32_USBControllerDevice")
 
    For Each objDevice In colDevices
        arrDeviceNames = Split(Replace(objDevice.Dependent, Chr(34), ""), "=")
        strDevicename = arrDeviceNames(1)
        Set colUSBDevices = objWMIService.ExecQuery _
            ("SELECT * From Win32_PnPEntity Where DeviceID = '" & strDevicename _
            & "'")
        For Each objUSBDevice In colUSBDevices
            If strUSBDeviceName = "*ListAllUSBDevices*" Then MsgBox _
              objUSBDevice.Description
            If InStr(objUSBDevice.Description, strUSBDeviceName) > 0 Then
                checkUSBDevice = True
            End If
        Next
    Next
End Function