How to get useful Windows device information in VBA

Here are (at least) 3 properties of hardware like hard disks (whether they are HDD, SSD, USB or else), printers or anything else that Windows considers a device. These can be very useful to obtain in applications that manage enterprise assets like data and documents:

Vendor name,
Vendor ID,
and serial number.

These hardware properties allow us to uniquely an reliably identify a physical device.

Unfortunately, they’re not so easy to obtain. Particularly if we develop our applications with the “high level” languages that we use in database management systems like Microsoft Access (but also WinDev or FileMaker to name a few others), or in development environments that do not have the necessary, production ready, components or libraries to interact with the system.

Then there are different technologies we can use to get to these hardware properties, like:

Windows Management Instrumentation (or WMI), which has already morphed into MI; it is feature rich and COM/ActiveX friendly, but – boy – what a learning curve and a maintenance nightmare threat that would be, just do such a simple thing;
.NET, although it would be like using a cannon to kill a mosquito to fire up the .NET runtime engine just to use a nugget of its capacities to bring this small functionality to applications that are not .NET based.
The venerable and almighty Win32 API, that we’ll use here from C, to bridge its functionality to Visual Basic, because the Win32 API is mostly C/C++ friendly; my winner here, attaboy.

So, let’s start at the end (!), because we want to get into action immediately, don’t we ?
Some explanation will follow later in this post.

Just before jumping there, let me point out where I am going with all this stuff next:

We’re going to combine this code in an out of process, Visual Basic 5 ActiveX EXE server. That will allow us to detect when a USB (or other device type) is plugged or unplugged into the system, in real time;
- I’ll use the same technique that allows us to detect when a user locks/unlocks his/her Windows session;
That’s for a bit later, we have some other things to talk about first, but I can’t resist the urge to spoil it:
using a similar technique (the ActiveX OOP EXE server), we’ll turn Access into a (local machine/network) Web server (whaaat ?!? – Yes, no apache, nginx, node, or whatever needed!)

Watch the (short) demo video

Get device information from an access database demo

Download

binaries
- deviceinfo.dll (32bits version, MD5 sum: fb86ea314cdc4b2fd42f01b3876230d3)
- deviceinfo64.dll (64bits version, MD5 sum: c27ce08c1c7d982bc475181d6f1cc613)
C DLL source code on my github
Access Demo database
- deviceinfo_dll.accdb (contains the MDeviceInfo.bas module with the necessary declares, and additional wrapping to easily use the DLL with one function call and a supporting Type definition).
  Important note: copy the two DLLs (deviceinfo.dll and deviceinfo64.dll) in the same directory where you put the demo database deviceinfo_dll.accdb. The DLLs have to be in one of your PATH directories, or in the same directory of the application using them.

Some (quick) explanation

We can see the VB/A declarations that import the DLL functions in the declarations section of the MDeviceInfo.bas module:

#If Win64 Then
Private Declare PtrSafe Function DICreateDeviceInfo Lib "deviceinfo64.dll" () As LongPtr
'etc...'
#Else
Private Declare Function DICreateDeviceInfo Lib "deviceinfo.dll" () As Long
'etc...'
#End If

#If Win64 Then

Private Declare PtrSafe Function DICreateDeviceInfo Lib "deviceinfo64.dll" () As LongPtr

'etc...'

#Else

Private Declare Function DICreateDeviceInfo Lib "deviceinfo.dll" () As Long

'etc...'

#End If

Get to one API function

Instead of crippling our code with calls to each of the DLL functions, we can create one single function that does it all:

Public Function DIGetDeviceInformation(ByVal psDriveLetter As String, ByRef ptRetDevInfo As TDevInfo) As Boolean
  Const LOCAL_ERR_CTX As String = "DIGetDeviceInformation"
  Const ERR_MEMORY As Long = -1&
  
  On Error GoTo DIGetDeviceInformation_Err
  ClearErr
  
  Dim fOK             As Boolean
  Dim sDrivePath      As String
  Dim sErrString      As String
  Dim lErrCode        As Long
  Dim sBuffer         As String
  #If Win64 Then
  Dim hDevInfo        As LongPtr
  #Else
  Dim hDevInfo        As Long
  #End If
  
  sDrivePath = "\\.\" & psDriveLetter & ":" & ChrW$(0)
  hDevInfo = DICreateDeviceInfo()
  If hDevInfo = 0 Then
    SetErr LOCAL_ERR_CTX, ERR_MEMORY, "Couldn't allocate memory to query for device information"
    Exit Function
  End If
  
  fOK = DIQueryDeviceInfo(hDevInfo, StrPtr(sDrivePath))
  If Not fOK Then
    sErrString = MakeBufferString(MAX_ERRSTR_LENGTH)
    lErrCode = DIGetLastErrorText(hDevInfo, StrPtr(sErrString), MAX_ERRSTR_LENGTH)
    SetErr LOCAL_ERR_CTX, lErrCode, Trim$(CtoVB(sErrString))
    GoTo DIGetDeviceInformation_Exit
  End If
  
  With ptRetDevInfo
    .lVersion = DIGetVersion(hDevInfo)
    .bDeviceType = DIGetDeviceType(hDevInfo)
    .bDeviceTypeModifier = DIGetDeviceTypeModifier(hDevInfo)
    .bRemovableMedia = DIGetRemovableMedia(hDevInfo)
    .bCommandQueueing = DIGetCommandQueueing(hDevInfo)
    .bBusType = DIGetBusType(hDevInfo)
    'retrieve strings
    sBuffer = MakeBufferString(INFOSTRING_MAX_LENGTH)
    DIGetVendorID hDevInfo, StrPtr(sBuffer), INFOSTRING_MAX_LENGTH
    .sVendorID = Trim$(CtoVB(sBuffer))
    sBuffer = MakeBufferString(INFOSTRING_MAX_LENGTH)
    DIGetProductID hDevInfo, StrPtr(sBuffer), INFOSTRING_MAX_LENGTH
    .sProductID = Trim$(CtoVB(sBuffer))
    sBuffer = MakeBufferString(INFOSTRING_MAX_LENGTH)
    DIGetProductRevision hDevInfo, StrPtr(sBuffer), INFOSTRING_MAX_LENGTH
    .sProductRevision = Trim$(CtoVB(sBuffer))
    sBuffer = MakeBufferString(INFOSTRING_MAX_LENGTH)
    DIGetSerialNumber hDevInfo, StrPtr(sBuffer), INFOSTRING_MAX_LENGTH
    .sSerialNumber = Trim$(CtoVB(sBuffer))
  End With
  
  DIGetDeviceInformation = True
  
DIGetDeviceInformation_Exit:
  If hDevInfo Then
    DIDestroyDeviceInfo hDevInfo
  End If
  Exit Function

DIGetDeviceInformation_Err:
  SetErr LOCAL_ERR_CTX, Err.Number, Err.Description
  Resume DIGetDeviceInformation_Exit
End Function

Public Function DIGetDeviceInformation(ByVal psDriveLetter As String, ByRef ptRetDevInfo As TDevInfo) As Boolean

Const LOCAL_ERR_CTX As String = "DIGetDeviceInformation"

Const ERR_MEMORY As Long = -1&

On Error GoTo DIGetDeviceInformation_Err

ClearErr

Dim fOK As Boolean

Dim sDrivePath As String

Dim sErrString As String

Dim lErrCode As Long

Dim sBuffer As String

#If Win64 Then

Dim hDevInfo As LongPtr

#Else

Dim hDevInfo As Long

#End If

sDrivePath = "\\.\" & psDriveLetter & ":" & ChrW$(0)

hDevInfo = DICreateDeviceInfo()

If hDevInfo = 0 Then

SetErr LOCAL_ERR_CTX, ERR_MEMORY, "Couldn't allocate memory to query for device information"

Exit Function

End If

fOK = DIQueryDeviceInfo(hDevInfo, StrPtr(sDrivePath))

If Not fOK Then

sErrString = MakeBufferString(MAX_ERRSTR_LENGTH)

lErrCode = DIGetLastErrorText(hDevInfo, StrPtr(sErrString), MAX_ERRSTR_LENGTH)

SetErr LOCAL_ERR_CTX, lErrCode, Trim$(CtoVB(sErrString))

GoTo DIGetDeviceInformation_Exit

End If

With ptRetDevInfo

.lVersion = DIGetVersion(hDevInfo)

.bDeviceType = DIGetDeviceType(hDevInfo)

.bDeviceTypeModifier = DIGetDeviceTypeModifier(hDevInfo)

.bRemovableMedia = DIGetRemovableMedia(hDevInfo)

.bCommandQueueing = DIGetCommandQueueing(hDevInfo)

.bBusType = DIGetBusType(hDevInfo)

'retrieve strings

sBuffer = MakeBufferString(INFOSTRING_MAX_LENGTH)

DIGetVendorID hDevInfo, StrPtr(sBuffer), INFOSTRING_MAX_LENGTH

.sVendorID = Trim$(CtoVB(sBuffer))

sBuffer = MakeBufferString(INFOSTRING_MAX_LENGTH)

DIGetProductID hDevInfo, StrPtr(sBuffer), INFOSTRING_MAX_LENGTH

.sProductID = Trim$(CtoVB(sBuffer))

sBuffer = MakeBufferString(INFOSTRING_MAX_LENGTH)

DIGetProductRevision hDevInfo, StrPtr(sBuffer), INFOSTRING_MAX_LENGTH

.sProductRevision = Trim$(CtoVB(sBuffer))

sBuffer = MakeBufferString(INFOSTRING_MAX_LENGTH)

DIGetSerialNumber hDevInfo, StrPtr(sBuffer), INFOSTRING_MAX_LENGTH

.sSerialNumber = Trim$(CtoVB(sBuffer))

End With

DIGetDeviceInformation = True

DIGetDeviceInformation_Exit:

If hDevInfo Then

DIDestroyDeviceInfo hDevInfo

End If

Exit Function

DIGetDeviceInformation_Err:

SetErr LOCAL_ERR_CTX, Err.Number, Err.Description

Resume DIGetDeviceInformation_Exit

End Function

This way, we don’t have to worry about forgetting to call the DICreateDeviceInfo() and DIDestroyDeviceInfo() functions that are necessary for the DLL to do its job without crashes.

We gather the retrieved device information in an easy to access structure, in the following (public) Type definition:

Public Type TDevInfo
  lVersion            As Long
  bDeviceType         As Byte
  bDeviceTypeModifier As Byte
  bRemovableMedia     As Byte
  bCommandQueueing    As Byte
  bBusType            As Byte
  sVendorID           As String
  sProductID          As String
  sProductRevision    As String
  sSerialNumber       As String
End Type

Public Type TDevInfo

lVersion As Long

bDeviceType As Byte

bDeviceTypeModifier As Byte

bRemovableMedia As Byte

bCommandQueueing As Byte

bBusType As Byte

sVendorID As String

sProductID As String

sProductRevision As String

sSerialNumber As String

End Type

Another way of doing it is using a class module. We’ll do that in the next post, where we set up the ActiveX OOP EXE server that will notify us of the devices arrival/removal in real time.

Sample usage

Take a look at the demo() procedure in the MMain.bas module:

Public Sub Demo()
  Dim sDriveLetter  As String
  Dim fOK           As Boolean
  Dim tDriveInfo    As TDevInfo
  
  Const LBLSIZE As Integer = 22
  
  ChDir CurrentProject.Path 'just to be sure our DLL is found
  
  Do
    sDriveLetter = InputBox$("Enter a drive letter (just the letter) or hit 'ESC' to end, please:")
    If Len(sDriveLetter) = 0 Then Exit Do
  
    fOK = DIGetDeviceInformation(UCase$(sDriveLetter), tDriveInfo)
    If fOK Then
      With tDriveInfo
        Debug.Print StrBlock("lVersion", " ", LBLSIZE), .lVersion
        Debug.Print StrBlock("bDeviceType", " ", LBLSIZE), .bDeviceType
        Debug.Print StrBlock("bDeviceTypeModifier", " ", LBLSIZE), .bDeviceTypeModifier
        Debug.Print StrBlock("bRemovableMedia", " ", LBLSIZE), .bRemovableMedia
        Debug.Print StrBlock("bCommandQueueing", " ", LBLSIZE), .bCommandQueueing
        Debug.Print StrBlock("bBusType", " ", LBLSIZE), .bBusType
        Debug.Print StrBlock("sVendorID", " ", LBLSIZE), .sVendorID
        Debug.Print StrBlock("sProductID", " ", LBLSIZE), .sProductID
        Debug.Print StrBlock("sProductRevision", " ", LBLSIZE), .sProductRevision
        Debug.Print StrBlock("sSerialNumber", " ", LBLSIZE), .sSerialNumber
      End With
    Else
      Debug.Print "FAILED (drive '"; sDriveLetter; "'): "; DILastErrDesc()
    End If
    Debug.Print "Press F5 to continue..." & vbCrLf
    Stop
  Loop
  
  Debug.Print "End of demo run"
End Sub

Public Sub Demo()

Dim sDriveLetter As String

Dim fOK As Boolean

Dim tDriveInfo As TDevInfo

Const LBLSIZE As Integer = 22

ChDir CurrentProject.Path 'just to be sure our DLL is found

sDriveLetter = InputBox$("Enter a drive letter (just the letter) or hit 'ESC' to end, please:")

If Len(sDriveLetter) = 0 Then Exit Do

fOK = DIGetDeviceInformation(UCase$(sDriveLetter), tDriveInfo)

If fOK Then

With tDriveInfo

Debug.Print StrBlock("lVersion", " ", LBLSIZE), .lVersion

Debug.Print StrBlock("bDeviceType", " ", LBLSIZE), .bDeviceType

Debug.Print StrBlock("bDeviceTypeModifier", " ", LBLSIZE), .bDeviceTypeModifier

Debug.Print StrBlock("bRemovableMedia", " ", LBLSIZE), .bRemovableMedia

Debug.Print StrBlock("bCommandQueueing", " ", LBLSIZE), .bCommandQueueing

Debug.Print StrBlock("bBusType", " ", LBLSIZE), .bBusType

Debug.Print StrBlock("sVendorID", " ", LBLSIZE), .sVendorID

Debug.Print StrBlock("sProductID", " ", LBLSIZE), .sProductID

Debug.Print StrBlock("sProductRevision", " ", LBLSIZE), .sProductRevision

Debug.Print StrBlock("sSerialNumber", " ", LBLSIZE), .sSerialNumber

End With

Else

Debug.Print "FAILED (drive '"; sDriveLetter; "'): "; DILastErrDesc()

End If

Debug.Print "Press F5 to continue..." & vbCrLf

Stop

Loop

Debug.Print "End of demo run"

End Sub

Anyway, if you made it thru here, thank for your attention, don’t hesitate to share a link to this post where you see fit, open or join the conversation here, or drop me a tweet (I’m @francescofoti), I’ll always appreciate that.

And see you soon, because we’re not done yet 😉