You could try the GetVolumeInformation API:
Private Declare Function GetVolumeInformation _
Lib "kernel32" _
Alias "GetVolumeInformationA" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
Function getDriveVolumeSerial(Optional strDriveLetter As String) As String
'will get the drive serial number
'default is the drive that the application is on
'otherwise can do for example: getDriveSerialNumber("D")
'-------------------------------------------------------
Dim strDrivePath As String
Dim Serial As Long
Dim VName As String
Dim FSName As String
If Len(strDriveLetter) = 0 Then
strDrivePath = Left$(Application.Path, 1) & ":\"
Else
strDrivePath = strDriveLetter & ":\"
End If
'Create buffers
VName = String$(255, Chr$(0))
FSName = String$(255, Chr$(0))
'Get the volume information
GetVolumeInformation strDrivePath, VName, 255, Serial, 0, 0, FSName, 255
getDriveVolumeSerial = Trim(Str$(Abs(Serial)))
End Function
Run it from the ThisWorkbook module in the Private Sub Workbook_Open()
RBS
