PDA

View Full Version : How to get the name of USB port name



clif
09-19-2016, 06:36 PM
I have two laser scanner connect to computer
Could i get the name of scanner when scanning by using VBA?

Thank you very much!

Kenneth Hobs
09-20-2016, 05:52 AM
Add the reference, run, and check the Immediate Window for results.



'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

Paul_Hossler
09-20-2016, 07:32 AM
Ken -- does that return the scanner name?

Kenneth Hobs
09-20-2016, 07:46 AM
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

Paul_Hossler
09-20-2016, 08:41 AM
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




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

w01w
02-05-2017, 11:49 AM
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

SamT
02-05-2017, 12:30 PM
Ken,

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



'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