harddisk.bas

使用WMI读取硬盘信息

                  Err.Raise 1101, "hdid9x", "DeviceIoControl failed:DFP_RECEIVE_DRIVE_DATA"
              End If
              
              Dim StrOut As String
              
              CopyMemory phdinfo, out_data.bBuffer(0), Len(phdinfo)
              
              CopyMemory s(0), phdinfo.sModelNumber(0), 40
              s(40) = 0
              ChangeByteOrder s, 40
              
              StrOut = ByteArrToString(s, 40)
              
'              hdid9x = hdid9x & vbCrLf & "Module Number:" & StrOut
              CopyMemory s(0), phdinfo.sFirmwareRev(0), 8
              s(8) = 0
              ChangeByteOrder s, 8
              
              StrOut = ByteArrToString(s, 8)
              
'              hdid9x = hdid9x & vbCrLf & "Firmware rev:" & StrOut
              CopyMemory s(0), phdinfo.sSerialNumber(0), 20
              s(20) = 0
              ChangeByteOrder s, 20
              
              StrOut = ByteArrToString(s, 20)
              rtn(0) = StrOut
              
'              hdid9x = hdid9x & vbCrLf & "Serial Number:" & StrOut
              
              CopyMemory s(0), phdinfo.ulTotalAddressableSectors(0), 4
              
              s(5) = 0
              Dim dblStrOut As Double
              dblStrOut = ByteArrToLong(s)
'              hdid9x = hdid9x & vbCrLf & "Capacity:" & dblStrOut / 2 / 1024 & "M"
          End If
    Next j
    
    'Close handle before quit
    CloseHandle (H)
    hdid9x = rtn
End Function

Private Function hdidnt() As String()
    Dim hd As String * 80
    Dim phdinfo As TIDSECTOR
    Dim s(40) As Byte
    Dim StrOut As String
    
    Dim rtn(0 To 3) As String
    
    hdidnt = rtn
    'We start in NT/Win2000
    
    For j = 0 To 3  '这里取四个硬盘的信息，因为正常PC不超过四个硬盘
         hd = "\\.\PhysicalDrive" & CStr(j)
'         hdidnt = hdidnt & vbCrLf & hd
'         h = CreateFile(hd, GENERIC_READ Or GENERIC_WRITE, _
'              FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)
         H = CreateFile(hd, GENERIC_READ Or GENERIC_WRITE, _
              FILE_SHARE_READ Or FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0)
         
         If H = 0 Then
'            MsgBox "Open smartvsd.vxd failed", vbCritical, "错误"
         End If
         
'         MsgBox "h=" & h
         
         Dim olpv As OVERLAPPED
         
         Dim lRet As Long
         lRet = DeviceIoControl(H, DFP_GET_VERSION, ByVal 0&, 0, vers, Len(vers), ByVal i, olpv)
         
'         MsgBox "lRet=" & lRet
         
         If lRet = 0 Then
             CloseHandle (H)
         Else
                'If IDE identify command not supported, fails
                If (vers.fCapabilities And 1) <> 1 Then
                      CloseHandle (H)
                      Err.Raise 1001, "", "Error: IDE identify command not supported."
                End If
                'Identify the IDE drives
                If (j And 1) = 1 Then
                    in_data.irDriveRegs.bDriveHeadReg = &HB0
                Else
                    in_data.irDriveRegs.bDriveHeadReg = &HA0
                End If
                If (vers.fCapabilities And (16 \ (2 ^ j))) <> 0 Then
                    'We don't detect a ATAPI device.
'                    hdidnt = hdidnt & vbCrLf & "Drive " & CStr(j + 1) & " is a ATAPI device, we don't detect it"
                    Err.Raise 1001, "", "Drive " & CStr(j + 1) & " is a ATAPI device, we don't detect it"
                Else
'                      MsgBox "1"
                      
                      in_data.irDriveRegs.bCommandReg = &HEC
                      in_data.bDriveNumber = j
                      in_data.irDriveRegs.bSectorCountReg = 1
                      in_data.irDriveRegs.bSectorNumberReg = 1
                      in_data.cBufferSize = 512
                      
                      Dim olpr As OVERLAPPED
                      
                      lRet = DeviceIoControl(H, DFP_RECEIVE_DRIVE_DATA, in_data, Len(in_data), out_data, Len(out_data), ByVal i, olpr)
                      If lRet <= 0 Then
'                           hdidnt = hdidnt & vbCrLf & "DeviceIoControl failed:DFP_RECEIVE_DRIVE_DATA"
                           CloseHandle (H)
                           Err.Raise 1001, "", "DeviceIoControl failed:DFP_RECEIVE_DRIVE_DATA"
                      Else
                   
'                        MsgBox "2"
                        
                        CopyMemory phdinfo, out_data.bBuffer(0), Len(phdinfo)
                        
                        CopyMemory s(0), phdinfo.sModelNumber(0), 40
                        s(40) = 0
                        ChangeByteOrder s, 40
                        
                        StrOut = ByteArrToString(s, 40)
                        
                        '                         hdidnt = hdidnt & vbCrLf & "Module Number:" & Trim(StrOut)
                        CopyMemory s(0), phdinfo.sFirmwareRev(0), 8
                        s(8) = 0
                        ChangeByteOrder s, 8
                        
                        StrOut = ByteArrToString(s, 8)
                        
                        '                         hdidnt = hdidnt & vbCrLf & "Firmware rev:" & StrOut
                        
                        CopyMemory s(0), phdinfo.sSerialNumber(0), 20
                        s(20) = 0
                        ChangeByteOrder s, 20
                        
                        StrOut = ByteArrToString(s, 20)
                        rtn(j) = StrOut
                        
                        '                         hdidnt = hdidnt & vbCrLf & "Serial Number:" & StrOut
                        
                        CopyMemory s(0), phdinfo.ulTotalAddressableSectors(0), 4
                        s(5) = 0
                        Dim dblStrOut As Double
                        dblStrOut = ByteArrToLong(s)
                        
                        '                         hdidnt = hdidnt & vbCrLf & "Capacity:" & dblStrOut / 2 / 1024 & "M"
                        CloseHandle (H)
                      End If
                End If
           End If
    Next j
    hdidnt = rtn
End Function

Public Function HardDiskSerial() As String()
    On Error GoTo ErrorHandle
    
    Dim VERINFO As OSVERSIONINFO
    Dim ret As Long
    
    VERINFO.dwOSVersionInfoSize = Len(VERINFO)
    ret = GetVersionEx(VERINFO)
    
    Dim OutStr() As String
    Select Case VERINFO.dwPlatformId
        Case VER_PLATFORM_WIN32S
            MsgBox "Win32s is not supported by this programm."
            
        Case VER_PLATFORM_WIN32_WINDOWS
            OutStr = hdid9x
        
        Case VER_PLATFORM_WIN32_NT
            OutStr = hdidnt
            
    End Select
    HardDiskSerial = OutStr
    
    Exit Function
ErrorHandle:
    ReDim OutStr(0 To 0) As String
'    OutStr(0) = MD5("FCDERTYUIOplkjhds" & GetSerialNumber("C:\") & "#$%^&*fgd")
    HardDiskSerial = OutStr
End Function


Private Function DetectIDE(bIDEDeviceMap As Byte) As String
    If (bIDEDeviceMap And 1) Then
        If (bIDEDeviceMap And 16) Then
             DetectIDE = DetectIDE & "ATAPI device is attached to primary controller, drive 0."
        Else
             DetectIDE = DetectIDE & "IDE device is attached to primary controller, drive 0."
        End If
    End If
    If (bIDEDeviceMap And 2) Then
        If (bIDEDeviceMap And 32) Then
             DetectIDE = DetectIDE & "ATAPI device is attached to primary controller, drive 1."
        Else
             DetectIDE = DetectIDE & "IDE device is attached to primary controller, drive 1."
        End If
    End If
    If (bIDEDeviceMap And 4) Then
        If (bIDEDeviceMap And 64) Then
             DetectIDE = DetectIDE & "ATAPI device is attached to secondary controller, drive 0."
        Else
             DetectIDE = DetectIDE & "IDE device is attached to secondary controller, drive 0."
        End If
    End If
    If (bIDEDeviceMap And 8) Then
        If (bIDEDeviceMap And 128) Then
             DetectIDE = DetectIDE & "ATAPI device is attached to secondary controller, drive 1."
        Else
             DetectIDE = DetectIDE & "IDE device is attached to secondary controller, drive 1."
        End If
    End If
End Function


Private Function ByteArrToString(inByte() As Byte, ByVal strlen As Integer) As String
    Dim i As Integer
    For i = 0 To strlen
        If inByte(i) = 0 Then
           Exit For
        End If
        ByteArrToString = ByteArrToString & Chr(inByte(i))
    Next i
End Function

Private Function ByteArrToLong(inByte() As Byte) As Double
    Dim i As Integer
    For i = 0 To 3
        ByteArrToLong = ByteArrToLong + CDbl(inByte(i)) * (256 ^ i)
    Next i
   
End Function