VB取硬盘的物理信息(序列号,容量,转速,型号)

' 
'取硬盘的物理信息(序列号,容量,转速,型号)(smHDinfo) 
' 
'/网站：东方热讯：http://www.easthot.net 
'/邮件：sales@easthot.net 
'/2003.01.23 
'************************************************************************* 
Option Explicit
'/以下这一行是必须的，困为要做结构复制。而结构中有数组。所以，没有它则会错位 
Option Base 0
Private Const DFP_GET_VERSION = 
Private Const DFP_SEND_DRIVE_COMMAND = 
Private Const DFP_RECEIVE_DRIVE_DATA = 
'/#pragma pack(1) 
Private Type TGETVERSIONOUTPARAMS   '{ 
    bVersion As Byte  '/Binary driver version. 
    bRevision As Byte '/Binary driver revision. 
    bReserved As Byte  '/Not used. 
    bIDEDeviceMap As Byte '/Bit map of IDE devices. 
    fCapabilities As Long '/Bit mask of driver capabilities. 
    dwReserved(4) As Long '/For future use. 
End Type
Private Type TIDEREGS
    bFeaturesReg As Byte   '/Used for specifying SMART "commands". 
    bSectorCountReg As Byte  '/IDE sector count register 
    bSectorNumberReg As Byte  '/IDE sector number register 
    bCylLowReg As Byte    '/IDE low order cylinder value 
    bCylHighReg As Byte   '/IDE high order cylinder value 
    bDriveHeadReg As Byte   '/IDE drive/head register 
    bCommandReg As Byte   '/Actual IDE command. 
    bReserved As Byte    '/reserved for future use.  Must be zero. 
End Type
Private Type TSENDCMDINPARAMS
    cBufferSize As Long   '/Buffer size in bytes 
    irDriveRegs As TIDEREGS   '/Structure with drive register values. 
    bDriveNumber As Byte   '/Physical drive number to send  '/command to (0,1,2,3). 
    bReserved(2) As Byte   '/Reserved for future expansion. 
    dwReserved(3) As Long   '/For future use. 
    '//BYTE  bBuffer(1)   '/Input buffer. 
End Type
Private Type TDRIVERSTATUS
    bDriverError As Byte  '/Error code from driver, '/or 0 if no error. 
    bIDEStatus  As Byte  '/Contents of IDE Error register. 
           '//Only valid when bDriverError '/is SMART_IDE_ERROR. 
    bReserved(1) As Byte   '/Reserved for future expansion. 
    dwReserved(1) As Long   '/Reserved for future expansion. 
End Type
Private Type TSENDCMDOUTPARAMS
    cBufferSize As Long      '/Size of bBuffer in bytes 
    DRIVERSTATUS As TDRIVERSTATUS   '/Driver status structure. 
    bBuffer(511) As Byte   '/Buffer of arbitrary length 
             '//in which to store the data read from the drive. 
End Type
'/下面的结构是要从另一结构复制数据过来的，所以，必须是字节数与VC的完全一致 
'/而不能用兼容变量，但这里的我们还是用了兼容变量，Integer,因为此结构中这一 
'/类型的的变量程序中没有用到，如果要用到，建议改为Byte类型。因为VB没有USHORT 
Private Type TIDSECTOR
    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   '/这里只能用byte，因为VB没有无符号的LONG型变量 
    wMultSectorStuff As Integer
    ulTotalAddressableSectors(3) As Byte '/这里只能用byte，因为VB没有无符号的LONG型变量 
    wSingleWordDMA As Integer
    wMultiWordDMA As Integer
    bReserved(127) As Byte
End Type
Private vers As TGETVERSIONOUTPARAMS
Private in_data As TSENDCMDINPARAMS
Private out_data As TSENDCMDOUTPARAMS
Private h As Long
Private I As Long
Private J As Byte
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" _
          (LpVersionInformation As OSVERSIONINFO) As Long
Private Const VER_PLATFORM_WIN32S = 0
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const VER_PLATFORM_WIN32_NT = 2
Private Declare Function CreateFile Lib "kernel32" _
    Alias "CreateFileA" (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 Const CREATE_NEW = 1
Private Const GENERIC_READ = 
Private Const GENERIC_WRITE = 
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = 
Private Const FILE_SHARE_WRITE = 
Private Type OVERLAPPED
    Internal As Long
    InternalHigh As Long
    offset As Long
    OffsetHigh As Long
    hEvent As Long
End Type
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 OVERLAPPED) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
         hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Sub ChangeByteOrder(szString() As Byte, uscStrSize As Long)
    Dim I As Long
    Dim temp As String
     For I = 0 To uscStrSize - 1 Step 2
        temp = szString(I)
        szString(I) = szString(I + 1)
        szString(I + 1) = temp
     Next I
End Sub
Private Function hdid9x() As smHdInfoType()
    '/We start in 95/98/Me 
    Dim RevInfo() As smHdInfoType
    Dim RevID As Long
    Dim olp As OVERLAPPED
    Dim lRet As Long
    
    h = CreateFile("//./Smartvsd", 0, 0, 0, CREATE_NEW, 0, 0)
    If h = 0 Then
        RevID = RevID + 1
        ReDim Preserve RevInfo(RevID - 1)
        RevInfo(RevID - 1).InfoFlag = False
        GoTo EndFun
    End If
    
    lRet = DeviceIoControl(h, DFP_GET_VERSION, ByVal 0&, 0, vers, Len(vers), ByVal I, olp)
    If lRet = 0 Then
        RevID = RevID + 1
        ReDim Preserve RevInfo(RevID - 1)
        RevInfo(RevID - 1).InfoFlag = False
        CloseHandle (h)
        GoTo EndFun
    End If
    
    '/If IDE identify command not supported, fails 
    If (vers.fCapabilities And 1) <> 1 Then
        '/hdid9x = "Error: IDE identify command not supported." 
        RevID = RevID + 1
        ReDim Preserve RevInfo(RevID - 1)
        RevInfo(RevID - 1).InfoFlag = False
        CloseHandle (h)
        GoTo EndFun
    End If
    
    '/Display IDE drive number detected 
    Dim sPreOutStr As String
    sPreOutStr = DetectIDE(vers.bIDEDeviceMap)
    '/hdid9x = sPreOutStr 
    
    '/Identify the IDE drives 
    For J = 0 To 3
        Dim phdinfo As TIDSECTOR
        Dim s(40) As Byte
        
        RevID = RevID + 1
        ReDim Preserve RevInfo(RevID - 1)
        RevInfo(RevID - 1).Hdid = J
        If (J And 1) = 1 Then
            in_data.irDriveRegs.bDriveHeadReg = 
        Else
            in_data.irDriveRegs.bDriveHeadReg = 
        End If
        If (vers.fCapabilities And (16 / (2 ^ J))) = (16 / (2 ^ J)) Then
            RevInfo(RevID - 1).InfoFlag = False
        Else
              in_data.irDriveRegs.bCommandReg = 
              in_data.bDriveNumber = J
              in_data.irDriveRegs.bSectorCountReg = 1
              in_data.irDriveRegs.bSectorNumberReg = 1
              in_data.cBufferSize = 512
              RevInfo(RevID - 1).InfoFlag = True
              lRet = DeviceIoControl(h, DFP_RECEIVE_DRIVE_DATA, in_data, Len(in_data), out_data, Len(out_data), ByVal I, olp)
              
              If lRet = 0 Then
                  RevInfo(RevID - 1).InfoFlag = False
                  CloseHandle (h)
                  GoTo EndFun
              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)
              RevInfo(RevID - 1).ModuleNumber = Trim$(StrOut)
              CopyMemory s(0), phdinfo.sFirmwareRev(0), 8
              s(8) = 0
              ChangeByteOrder s, 8
              
              StrOut = ByteArrToString(s, 8)
              RevInfo(RevID - 1).FirmwareRev = Trim$(StrOut)
              CopyMemory s(0), phdinfo.sSerialNumber(0), 20
              s(20) = 0
              ChangeByteOrder s, 20
              
              StrOut = ByteArrToString(s, 20)
              '/hdid9x = hdid9x & vbCrLf & "Serial Number:" & StrOut 
              RevInfo(RevID - 1).SerialNumber = Trim$(StrOut)
              CopyMemory s(0), phdinfo.ulTotalAddressableSectors(0), 4
              s(5) = 0
              Dim dblStrOut As Double
              dblStrOut = ByteArrToLong(s)
              RevInfo(RevID - 1).Capcity = CLng(dblStrOut / 2 / 1024) & "M"
          End If
    Next J
    '/Close handle before quit 
    CloseHandle (h)
EndFun:
    hdid9x = RevInfo
End Function
Private Function hdidnt() As smHdInfoType()
    Dim hd As String * 80
    Dim phdinfo As TIDSECTOR
    Dim s(40) As Byte
    Dim StrOut As String
    
    Dim RevInfo() As smHdInfoType
    Dim RevID As Long
    
    '/hdidnt = "" 
    '/We start in NT/Win2000 
    
    For J = 0 To 3  '/这里取四个硬盘的信息，因为正常PC不超过四个硬盘 
         RevID = RevID + 1
         ReDim Preserve RevInfo(RevID - 1)
         RevInfo(RevID - 1).Hdid = CStr(J)
         
         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)
         
         Dim olpv As OVERLAPPED
         Dim lRet As Long
         
         lRet = DeviceIoControl(h, DFP_GET_VERSION, ByVal 0&, 0, vers, Len(vers), ByVal I, olpv)
         
         If lRet = 0 Then
            RevInfo(RevID - 1).InfoFlag = False
            CloseHandle (h)
         Else
                '/If IDE identify command not supported, fails 
                If (vers.fCapabilities And 1) <> 1 Then
                      '/hdidnt = "Error: IDE identify command not supported." 
                      RevInfo(RevID - 1).InfoFlag = False
                      CloseHandle (h)
                      GoTo EndFun
                      '/Exit Function 
                End If
                '/Identify the IDE drives 
                If (J And 1) = 1 Then
                    in_data.irDriveRegs.bDriveHeadReg = 
                Else
                    in_data.irDriveRegs.bDriveHeadReg = 
                End If
                If (vers.fCapabilities And (16 / (2 ^ J))) <> 0 Then
                    '/We don't detect a ATAPI device. 
                    RevInfo(RevID - 1).InfoFlag = False
                    
                    '/hdidnt = hdidnt & vbCrLf & "Drive " & CStr(j + 1) & " is a ATAPI device, we don't detect it" 
                Else
                      
                      in_data.irDriveRegs.bCommandReg = 
                      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" 
                           RevInfo(RevID - 1).InfoFlag = False
                           CloseHandle (h)
                           
                      Else
                         RevInfo(RevID - 1).InfoFlag = True
                         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)
                         RevInfo(RevID - 1).ModuleNumber = Trim$(StrOut)
                         '/hdidnt = hdidnt & vbCrLf & "Module Number:" & StrOut 
                         CopyMemory s(0), phdinfo.sFirmwareRev(0), 8
                         s(8) = 0
                         ChangeByteOrder s, 8
                         
                         StrOut = ByteArrToString(s, 8)
                         RevInfo(RevID - 1).FirmwareRev = Trim$(StrOut)
                         '/hdidnt = hdidnt & vbCrLf & "Firmware rev:" & StrOut 
                         CopyMemory s(0), phdinfo.sSerialNumber(0), 20
                         s(20) = 0
                         ChangeByteOrder s, 20
                         
                         StrOut = ByteArrToString(s, 20)
                         
                         '/hdidnt = hdidnt & vbCrLf & "Serial Number:" & StrOut 
                         RevInfo(RevID - 1).SerialNumber = Trim$(StrOut)
                         CopyMemory s(0), phdinfo.ulTotalAddressableSectors(0), 4
                         s(5) = 0
                         Dim dblStrOut As Double
                         dblStrOut = ByteArrToLong(s)
                         RevInfo(RevID - 1).Capcity = CLng(dblStrOut / 2 / 1024) & "M"
                         '/hdidnt = hdidnt & vbCrLf & "Capacity:" & dblStrOut / 2 / 1024 & "M" 
                         CloseHandle (h)
                      End If
                End If
           End If
    Next
EndFun:
    hdidnt = RevInfo
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
Public Function GetHdInfo() As smHdInfoType()
    Dim RevInfo() As smHdInfoType
    Dim verinfo As OSVERSIONINFO
    Dim Ret As Long
    
    verinfo.dwOSVersionInfoSize = Len(verinfo)
    Ret = GetVersionEx(verinfo)
    
    Select Case verinfo.dwPlatformId
    Case VER_PLATFORM_WIN32S
         ReDim RevInfo(1)
         RevInfo(0).InfoFlag = False
    Case VER_PLATFORM_WIN32_WINDOWS
        RevInfo = hdid9x()
    Case VER_PLATFORM_WIN32_NT
        RevInfo = hdidnt()
    End Select
    GetHdInfo = RevInfo
End Function