Attribute VB_Name = "Module_磁盤序列號"
Option Explicit

Private Type TYPEEdition
    bVersion                        As Byte
    bRevision                       As Byte
    bReserved                       As Byte
    bIDEDeviceMap                   As Byte
    fCapabilities                   As Long
    dwReserved(4)                   As Long
End Type

Private Type TYPETIDEreg
    bFeaturesReg                    As Byte
    bSectorCountReg                 As Byte
    bSectorNumberReg                As Byte
    bCylLowReg                      As Byte
    bCylHighReg                     As Byte
    bDriveHeadReg                   As Byte
    bCommandReg                     As Byte
    bReserved                       As Byte
End Type

Private Type TYPETSendCmdIn
    cBufferSize                     As Long
    irDriveRegs                     As TYPETIDEreg
    bDriveNumber                    As Byte
    bReserved(2)                    As Byte
    dwReserved(3)                   As Long
End Type

Private Type TYPEDRVInfos
    bDriverError                    As Byte
    bIDEStatus                      As Byte
    bReserved(1)                    As Byte
    dwReserved(1)                   As Long
End Type

Private Type TYPETSendCmdOut
    cBufferSize                     As Long
    DRIVERSTATUS                    As TYPEDRVInfos
    bBuffer(511)                    As Byte
End Type

Private Type TYPETIDSector
    wGenConfig                      As Integer
    wNumCyls                        As Integer
    wReserved                       As Integer
    wNumHeads                       As Integer
    wBytesPerTrack                  As Integer
    wBytesPerSector                 As Integer
    wSectorsPerTrack                As Integer
    wVendorUnique(2)                As Integer
    sSerialNumber(19)               As Byte
    wBufferType                     As Integer
    wBufferSize                     As Integer
    wECCSize                        As Integer
    sFirmwareRev(7)                 As Byte
    sModelNumber(39)                As Byte
    wMoreVendorUnique               As Integer
    wDoubleWordIO                   As Integer
    wCapabilities                   As Integer
    wReserved1                      As Integer
    wPIOTiming                      As Integer
    wDMATiming                      As Integer
    Wbs                             As Integer
    wNumCurrentCyls                 As Integer
    wNumCurrentHeads                As Integer
    wNumCurrentSectorsPerTrack      As Integer
    ulCurrentSectorCapacity(3)      As Byte
    wMultSectorStuff                As Integer
    ulTotalAddressableSectors(3)    As Byte
    wSingleWordDMA                  As Integer
    wMultiWordDMA                   As Integer
    bReserved(127)                  As Byte
End Type

Private Type TYPEOverLapped
    Internal                        As Long
    InternalHigh                    As Long
    offset                          As Long
    OffsetHigh                      As Long
    hEvent                          As Long
End Type

'Private Type TYPESecurity
'    nLength                         As Long
'    lpSecurityDescriptor            As Long
'    bInheritHandle                  As Long
'End Type

'// －kernel32－
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateFileA Lib "kernel32" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function RtlMoveMemory Lib "kernel32" (ByRef lpvDest As Any, ByRef lpvSource As Any, ByVal lpvLength As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, ByRef lpInBuffer As Any, ByVal nInBufferSize As Long, ByRef lpOutBuffer As Any, ByVal nOutBufferSize As Long, ByVal lpBytesReturned As Long, ByRef lpOverlapped As TYPEOverLapped) As Long
'Private Declare Function BrandExecute Lib "Shell32" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long      ' 運行文件

'// －硬盤編號－
Public Function ReadDiskSerialNumber(ByVal DiskNumber As Long) As String
    On Error Resume Next
    Dim hWnd As Long, Olpv As TYPEOverLapped
    Dim PhdInfo As TYPETIDSector, ArrayReturn(40) As Byte
    Dim InInfo As TYPETSendCmdIn, OutInfo As TYPETSendCmdOut, DeviceInfo As TYPEEdition
    hWnd = CreateFileA("\\.\PhysicalDrive" & CStr(DiskNumber - 1), &H80000000 Or &H40000000, &H1 Or &H2, 0, 3, 0, 0)
    If CBool(DeviceIoControl(hWnd, &H74080, ByVal 0&, 0, DeviceInfo, Len(DeviceInfo), ByVal 0, Olpv)) Then
        If CBool(DeviceInfo.fCapabilities) Then
            With InInfo
                .irDriveRegs.bDriveHeadReg = IIf(CBool(DiskNumber - 1), &HB0, &HA0)
                .irDriveRegs.bCommandReg = &HEC
                .bDriveNumber = DiskNumber - 1
                .irDriveRegs.bSectorCountReg = 1
                .irDriveRegs.bSectorNumberReg = 1
                .cBufferSize = 512
            End With
        
            If DeviceIoControl(hWnd, &H7C088, InInfo, Len(InInfo), OutInfo, Len(OutInfo), ByVal 0, Olpv) > 0 Then
                Call RtlMoveMemory(PhdInfo, OutInfo.bBuffer(0), Len(PhdInfo))
                Call RtlMoveMemory(ArrayReturn(0), PhdInfo.sSerialNumber(0), 40)
                ReadDiskSerialNumber = ByteToString(ArrayReturn)
            End If
        End If
    End If
    Call CloseHandle(hWnd)
    
    Call Err.Clear
    DoEvents
End Function
 
 '// －字節轉換－
Private Function ByteToString(ByRef ArrayByte() As Byte) As String
    On Error Resume Next
    Dim vPst As Long, VTemp As String
    For vPst = 1 To UBound(ArrayByte) Step 2
        VTemp = VTemp & Chr(ArrayByte(vPst)) & Chr(ArrayByte(vPst - 1))
    Next vPst
    For vPst = 1 To UBound(ArrayByte)
        If Mid$(VTemp, vPst, 1) = Chr(32) Then
            If Mid$(VTemp, vPst + 1, 1) = Chr(32) Then Exit For
            ByteToString = ByteToString & Mid$(VTemp, vPst, 1)
        Else
            ByteToString = ByteToString & Mid$(VTemp, vPst, 1)
        End If
    Next vPst
End Function