Function GetPhysicalDriveSerialNumber(Optional ID As Integer = 0, Optional bSepar As Boolean = True) As String
GetPhysicalDriveSerialNumber = "0000-0000"
On Local Error Resume Next
Dim sComputerName$
sComputerName = Environ$("COMPUTERNAME")
Dim WMI_Obj As Object, WMI_ObjProps As Object, ObjClsItem As Object
Set WMI_Obj = GetObject("winmgmts:\\" & sComputerName & "\root\cimv2")
Set WMI_ObjProps = WMI_Obj.ExecQuery("Select * from Win32_PhysicalMedia", , 48)
Dim sRet As String
For Each ObjClsItem In WMI_ObjProps
If ObjClsItem.Tag = "\\.\PHYSICALDRIVE" & CStr(ID) Then
' ici le serial en base16 ou 10
sRet = Trim$(ObjClsItem.SerialNumber)
' conversion base10
If Not (LenB(sRet) = 16) Then sRet = GetBase10FromBase16(sRet)
' ok, retour
If bSepar Then
GetPhysicalDriveSerialNumber = UCase$(LeftB$(sRet, 8) & "-" & RightB$(sRet, 8))
Else
GetPhysicalDriveSerialNumber = UCase$(sRet)
End If
Exit For
End If
Next ObjClsItem
Set ObjClsItem = Nothing
Set WMI_ObjProps = Nothing
Set WMI_Obj = Nothing
End Function
Private Function GetBase10FromBase16(ByVal sStr As String) As String
Dim i As Integer
sStr = Replace(sStr, "20", vbNullString)
GetBase10FromBase16 = Space$(8)
For i = 1 To 15 Step 2
Mid$(GetBase10FromBase16, i \ 2 + 1, 1) = Chr$(Val("&H" & Mid$(sStr, i, 2)))
Next i
End Function