How to get the name of USB port name

I have two laser scanner connect to computer
Could i get the name of scanner when scanning by using VBA?

Thank you very much!

Add the reference, run, and check the Immediate Window for results.

Code:

---


'Add reference: Microsoft Scripting Runtime
Sub DrivesInfo()
    Dim fso As FileSystemObject, aDrive As Drive


    Set fso = New FileSystemObject
    'Set aDrive = fso.GetDrive("C:\")
   
    On Error Resume Next
    For Each aDrive In fso.Drives
      With aDrive
        Debug.Print "Drive Type: " & .DriveType
        Debug.Print "Drive Letter: " & .DriveLetter
        Debug.Print "Share Name" & .ShareName
        Debug.Print "Volume Name: " & .VolumeName
        Debug.Print "Free Space: " & Format(.FreeSpace / 1000000000#, "#0.00") & "GB"
        Debug.Print "Total Size: " & Format(.TotalSize / 1000000000#, "#0.00") & "GB"
        Debug.Print "Ready: " & .IsReady
        Debug.Print vbCrLf
      End With
    Next aDrive
   
    Set fso = Nothing
    Set aDrive = Nothing
End Sub

---

Ken -- does that return the scanner name?

I doubt it. The OP asked for USB data which is a drive.

What the OP probably needs is printer name and port information. That requires another method. e.g. http://www.cpearson.com/excel/GetPrinters.aspx

Not my work, but I extracted enough to return the scanner's name (based on the service being 'usbscan') into a function called 'FindScanner'

I only have one scanner so once it's found, I exit,

You could change it to return a list of scanners

Code:

---

Option Explicit

Sub drv()
MsgBox FindScanner
End Sub
   
Function FindScanner() As String
    'Declaring the necessary variables.
    Dim strComputer    As String
    Dim strDeviceName  As String
    Dim objWMIService  As Object
    Dim colControllers  As Object
    Dim objController  As Object
    Dim colUSBDevices  As Object
    Dim objUSBDevice    As Object
    Dim i              As Integer
   
    'Just in case of an error...
    On Error Resume Next
   
    'Disable screen flickering.
    Application.ScreenUpdating = False
   
    'Set the computer.
    strComputer = "."
   
    'The root\cimv2 namespace is used to access the Win32_USBControllerDevice class.
    Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\cimv2")
   
    'A select query is used to get the list of all USB controllers.
    Set colControllers = objWMIService.ExecQuery("Select * From Win32_USBControllerDevice")
   
    'Start below sheet headings.
    i = 2
   
    'Loop through all the collection of USB controllers.
    For Each objController In colControllers
     
      'Retrieve the device name from the controller.
      strDeviceName = Replace(objController.Dependent, Chr(34), "")
      strDeviceName = Right(strDeviceName, Len(strDeviceName) - WorksheetFunction.Find("=", strDeviceName))
     
      'Execute a select query on Win32_PnPEntity class based on device name.
      Set colUSBDevices = objWMIService.ExecQuery("Select * From Win32_PnPEntity Where DeviceID = '" & strDeviceName & "'")
     
      'Loop through all the USB devices and write the necessary data in the sheet.
      For Each objUSBDevice In colUSBDevices
            If objUSBDevice.Service = "usbscan" Then
                FindScanner = objUSBDevice.Name
                Exit Function
            End If
            i = i + 1
        Next
    Next
End Function

Sub RetrieveUSBInfo()
    '--------------------------------------------------------------------------------------------------
    'Loops through all the USB controllers and devices (sticks, hubs, etc.) and retrieves information.
    'The code uses a WMI script in order to access the Win32_USBControllerDevice class.
         
    'Written by:    Christos Samaras
    'Date:          13/01/2014
    'e-mail:        xristos.samaras@gmail.com
    'site:          http://www.myengineeringworld.net
    '--------------------------------------------------------------------------------------------------
 
    'Declaring the necessary variables.
    Dim strComputer    As String
    Dim strDeviceName  As String
    Dim objWMIService  As Object
    Dim colControllers  As Object
    Dim objController  As Object
    Dim colUSBDevices  As Object
    Dim objUSBDevice    As Object
    Dim i              As Integer
    Dim shUSB As Worksheet
   
   
    Set shUSB = Worksheets("USB")
   
    'Just in case of an error...
    On Error Resume Next
   
    'Disable screen flickering.
    Application.ScreenUpdating = False
   
    'Clear the sheet (except headings).
    shUSB.Range("A2:E1048576").ClearContents
   
    'Set the computer.
    strComputer = "."
   
    'The root\cimv2 namespace is used to access the Win32_USBControllerDevice class.
    Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\cimv2")
   
    'A select query is used to get the list of all USB controllers.
    Set colControllers = objWMIService.ExecQuery("Select * From Win32_USBControllerDevice")
   
    'Start below sheet headings.
    i = 2
   
    'Loop through all the collection of USB controllers.
    For Each objController In colControllers
     
      'Retrieve the device name from the controller.
      strDeviceName = Replace(objController.Dependent, Chr(34), "")
      strDeviceName = Right(strDeviceName, Len(strDeviceName) - WorksheetFunction.Find("=", strDeviceName))
     
      'Execute a select query on Win32_PnPEntity class based on device name.
      Set colUSBDevices = objWMIService.ExecQuery("Select * From Win32_PnPEntity Where DeviceID = '" & strDeviceName & "'")
     
      'Loop through all the USB devices and write the necessary data in the sheet.
      For Each objUSBDevice In colUSBDevices
            With shUSB
                .Cells(i, 1).Value = objUSBDevice.Name
                .Cells(i, 2).Value = objUSBDevice.Manufacturer
                .Cells(i, 3).Value = objUSBDevice.Status
                .Cells(i, 4).Value = objUSBDevice.Service
                .Cells(i, 5).Value = objUSBDevice.DeviceID
            End With
            i = i + 1
        Next
    Next
   
    'Adjust columns width.
    shUSB.Columns("A:E").AutoFit
   
    'Inform the user about the process.
    MsgBox "Information from " & i - 2 & " USB devices was retrieved successfully!", vbInformation, "Finished"
   
End Sub

---

Hello,
Is it possible by adapting your code (I am not enough VBA specialist)
To do this:
Use several keyboards on a single PC and inform different cells?
Example:
Keyboard 1 (port usb1; hub1 => Cell A1 in sheet1
Keyboard 2 (port usb2, hub1 => Cell B1 in sheet1
Etc.

(Win10 / 64bits & Excel 2010 32bits, VBA 7.0)
Thank you for your help

Ken,

I had to rearrange your code e'er so slightly to make it run without errors

Code:

---



 'Add reference: Microsoft Scripting Runtime
 'See output in Immediate Window
 
 Sub DrivesInfo()
    Dim fso As FileSystemObject, aDrive As Drive
   
   
    Set fso = New FileSystemObject
    'Set aDrive = fso.GetDrive("C:\")
   
    On Error Resume Next
    Application.DisplayAlerts = False
    For Each aDrive In fso.Drives
        With aDrive
            Debug.Print "Drive Type: " & .DriveType
            Debug.Print "Drive Letter: " & .DriveLetter
            Debug.Print "Share Name" & .ShareName
            Debug.Print "Ready: " & .IsReady
            If Not .IsReady Then GoTo nextdrive

            Debug.Print "Volume Name: " & .VolumeName
            Debug.Print "Free Space: " & Format(.FreeSpace / 1000000000#, "#0.00") & "GB"
            Debug.Print "Total Size: " & Format(.TotalSize / 1000000000#, "#0.00") & "GB"
        End With
nextdrive:
        Debug.Print vbCrLf
    Next aDrive
    Set fso = Nothing
    Set aDrive = Nothing
End Sub

---