Получить аппаратный номер диска

Option Explicit
 
Private Type LARGE_INTEGER
    lowpart             As Long
    highpart            As Long
End Type
Private Type DISK_EXTENT
    DiskNumber          As Long
    Padding             As Long
    StartingOffset      As LARGE_INTEGER
    ExtentLength        As LARGE_INTEGER
End Type
Private Type VOLUME_DISK_EXTENTS
    NumberOfDiskExtents As Long
    Padding             As Long
    Extents(255)        As DISK_EXTENT
End Type
Private Type STORAGE_PROPERTY_QUERY
    PropertyId          As Long
    QueryType           As Long
    Dat(3)              As Byte
End Type
Private Type STORAGE_DESCRIPTOR_HEADER
    Version             As Long
    Size                As Long
End Type
Private Type STORAGE_DEVICE_DESCRIPTOR
    desc                As STORAGE_DESCRIPTOR_HEADER
    DeviceType          As Byte
    DeviceTypeModifier  As Byte
    RemovableMedia      As Byte
    CommandQueueing     As Byte
    VendorIdOffset      As Long
    ProductIdOffset     As Long
    ProductRevOffset    As Long
    SerialNumberOffset  As Long
    BusType             As Long
    RawPropertiesLength As Long
End Type
 
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsW" (ByVal nBufferLength As Long, _
                                                                                                ByVal lpBuffer As Long) As Long
 
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, _
                                                         ByVal dwIoControlCode As Long, _
                                                         lpInBuffer As Any, _
                                                         ByVal nInBufferSize As Long, _
                                                         lpOutBuffer As Any, _
                                                         ByVal nOutBufferSize As Long, _
                                                         lpBytesReturned As Long, _
                                                         lpOverlapped As Any) As Long
                                                         
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileW" (ByVal lpFileName As Long, _
                                                                        ByVal dwDesiredAccess As Long, _
                                                                        ByVal dwShareMode As Long, _
                                                                        lpSecurityAttributes As Any, _
                                                                        ByVal dwCreationDisposition As Long, _
                                                                        ByVal dwFlagsAndAttributes As Long, _
                                                                        ByVal hTemplateFile As Long) As Long
 
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, _
                                                                     Source As Any, _
                                                                     ByVal Length As Long)
 
 
Private Const FILE_SHARE_READ                       As Long = &H1
Private Const FILE_SHARE_WRITE                      As Long = &H2
Private Const OPEN_EXISTING                         As Long = 3
Private Const IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS  As Long = &H560000
Private Const IOCTL_STORAGE_QUERY_PROPERTY          As Long = &H2D1400
Private Const StorageDeviceProperty                 As Long = 0
Private Const PropertyStandardQuery                 As Long = 0
 
Private Function GetHardDiskSerialNumber(LogDrive As String) As String
    Dim hFile   As Long
    Dim ext     As VOLUME_DISK_EXTENTS
    Dim Size    As Long
    Dim retn    As Long
    ' Открываем логический диск
    hFile = CreateFile(StrPtr("\\.\" & LogDrive), _
                       0, _
                       FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                       ByVal 0, _
                       OPEN_EXISTING, _
                       0, _
                       0)
    
    If hFile <> -1 Then
        ' Запрашиваем физический диск (предполагаем что он 1)
        retn = DeviceIoControl(hFile, _
                               IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS, _
                               ByVal 0, _
                               0, _
                               ext, _
                               Len(ext), _
                               Size, _
                               ByVal 0)
        
        CloseHandle hFile
        ' Открываем физический диск
        hFile = CreateFile(StrPtr("\\.\PhysicalDrive" & CStr(ext.Extents(0).DiskNumber)), _
                           0, _
                           FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                           ByVal 0, _
                           OPEN_EXISTING, _
                           0, _
                           0)
        
        If hFile <> -1 Then
            Dim propQuery   As STORAGE_PROPERTY_QUERY
            Dim buffer()    As Byte
            ' Запрашиваем информацию
            ReDim buffer(32767)
            
            retn = DeviceIoControl(hFile, _
                                   IOCTL_STORAGE_QUERY_PROPERTY, _
                                   propQuery, _
                                   Len(propQuery), _
                                   buffer(0), _
                                   UBound(buffer) + 1, _
                                   Size, _
                                   ByVal 0)
                                   
            If retn Then
                Dim desc    As STORAGE_DEVICE_DESCRIPTOR
                Dim snHex() As Byte
                Dim symb    As Long
                Dim code    As Long
                ' Отсюда можно получить много информации
                CopyMemory desc, buffer(0), Len(desc)
                ' Нас интересует серийный номер
                symb = desc.SerialNumberOffset
                ' Если он представлен конвертируем его из HEX в строку
                If symb > 0 Then
                    Do Until buffer(symb) = 0
                    
                        If buffer(symb) > &H39 Then
                            ' A..F
                            code = (buffer(symb) - &H37) Or code * &H10
                        ElseIf buffer(symb) > &H46 Then
                            ' a..f
                            code = buffer(symb) - &H57 Or code * &H10
                        Else
                            ' 0..9
                            code = buffer(symb) - &H30 Or code * &H10
                        End If
                        
                        symb = symb + 1
                        
                        If ((symb - desc.SerialNumberOffset) And 3) = 0 Then
                            GetHardDiskSerialNumber = GetHardDiskSerialNumber & Chr$(code And &HFF) & Chr$((code \ &H100) And &HFF)
                            code = 0
                        End If
                        
                    Loop
                End If
                
            End If
        
            CloseHandle hFile
            
        End If
        
    End If
    ' Обрезаем пробелы
    GetHardDiskSerialNumber = Trim$(GetHardDiskSerialNumber)
    
End Function
 
Private Sub Form_Load()
    MsgBox Chr$(34) & GetHardDiskSerialNumber("C:") & Chr$(34)
End Sub