modulehdd.bas

来自「仓库扫描管理系统」· BAS 代码 · 共 518 行 · 第 1/2 页

    End If
    If (vers.fCapabilities And (16 \ (2 ^ j))) = (16 \ (2 ^ j)) Then
        'We don't detect a ATAPI device.
        hdid9x = "Drive " & CStr(j + 1) & " is a ATAPI device, we don't detect it"
    Else
          in_data.irDriveRegs.bCommandReg = &HEC
          in_data.bDriveNumber = j
          in_data.irDriveRegs.bSectorCountReg = 1
          in_data.irDriveRegs.bSectorNumberReg = 1
          in_data.cBufferSize = 512
          
          lRet = DeviceIoControl(h, DFP_RECEIVE_DRIVE_DATA, in_data, Len(in_data), out_data, Len(out_data), ByVal i, olp)
          
          If lRet = 0 Then
              hdid9x = "DeviceIoControl failed:DFP_RECEIVE_DRIVE_DATA"
              CloseHandle (h)
              Exit Function
          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)
moduleNumber = StrOut
          hdid9x = hdid9x & vbCrLf & "Module Number:" & StrOut
          CopyMemory s(0), phdinfo.sFirmwareRev(0), 8
          s(8) = 0
          ChangeByteOrder s, 8
          
          StrOut = ByteArrToString(s, 8)
firmwareRev = StrOut
          hdid9x = hdid9x & vbCrLf & "Firmware rev:" & StrOut
          CopyMemory s(0), phdinfo.sSerialNumber(0), 20
          s(20) = 0
          ChangeByteOrder s, 20
          
          StrOut = ByteArrToString(s, 20)
serialNumber = StrOut
          hdid9x = hdid9x & vbCrLf & "Serial Number:" & StrOut
          
          CopyMemory s(0), phdinfo.ulTotalAddressableSectors(0), 4
          
          s(5) = 0
          Dim dblStrOut As Double
          dblStrOut = ByteArrToLong(s)
capacity = CStr(dblStrOut)
          hdid9x = hdid9x & vbCrLf & "Capacity:" & dblStrOut / 2 / 1024 & "M"
      End If
Next j
'hdid9x = Trim(moduleNumber) & " " + Trim(firmwareRev) & "" & Trim(serialNumber) & "" & Trim(capacity)
hdid9x = Trim(serialNumber)
'Close handle before quit
CloseHandle (h)
'CopyRight

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

hdidnt = ""
'We start in NT/Win2000

For j = 0 To 0  '这里取一个硬盘的信息，因为正常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)
     
     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
         CloseHandle (h)
     Else
            'If IDE identify command not supported, fails
            If (vers.fCapabilities And 1) <> 1 Then
                  hdidnt = "Error: IDE identify command not supported."
                  CloseHandle (h)
                  Exit Function
            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"
            Else
                  
                  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)
                       
                  Else
               
                     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)
moduleNumber = StrOut
                     hdidnt = hdidnt & vbCrLf & "Module Number:" & StrOut
                     CopyMemory s(0), phdinfo.sFirmwareRev(0), 8
                     s(8) = 0
                     ChangeByteOrder s, 8
                     
                     StrOut = ByteArrToString(s, 8)
firmwareRev = StrOut
                     hdidnt = hdidnt & vbCrLf & "Firmware rev:" & StrOut
                     CopyMemory s(0), phdinfo.sSerialNumber(0), 20
                     s(20) = 0
                     ChangeByteOrder s, 20
                     
                     StrOut = ByteArrToString(s, 20)
serialNumber = StrOut
                     hdidnt = hdidnt & vbCrLf & "Serial Number:" & StrOut
                     
                     CopyMemory s(0), phdinfo.ulTotalAddressableSectors(0), 4
                     s(5) = 0
                     Dim dblStrOut As Double
                     dblStrOut = ByteArrToLong(s)
capacity = CStr(dblStrOut)
                     hdidnt = hdidnt & vbCrLf & "Capacity:" & dblStrOut / 2 / 1024 & "M"
                     CloseHandle (h)
                  End If
            End If
       End If
Next j
'hdidnt = Trim(moduleNumber) & " " + Trim(firmwareRev) & "" & Trim(serialNumber) & "" & Trim(capacity)
hdidnt = Trim(serialNumber)
'CopyRight

End Function

'Sub Main()
'
'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."
'    End
'Case VER_PLATFORM_WIN32_WINDOWS
'    OutStr = hdid9x
'    MsgBox OutStr
'    End
'Case VER_PLATFORM_WIN32_NT
'    OutStr = hdidnt
'    MsgBox OutStr
'    End
'End Select
'
'End Sub

Public Function getHddInfo()
    Dim verinfo As OSVERSIONINFO
    Dim Ret As Long
    verinfo.dwOSVersionInfoSize = Len(verinfo)
    Ret = GetVersionEx(verinfo)
    'Dim getHDDInfo As String
    Select Case verinfo.dwPlatformId
    Case VER_PLATFORM_WIN32S
    '    MsgBox "Win32s is not supported by this programm."
        Exit Function
    Case VER_PLATFORM_WIN32_WINDOWS
        getHddInfo = hdid9x
    '    MsgBox getHDDInfo
        Exit Function
    Case VER_PLATFORM_WIN32_NT
        getHddInfo = hdidnt
    '    MsgBox getHDDInfo
        Exit Function
    End Select
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 + Val(inByte(i)) * (256 ^ i)
    Next i
   
End Function


'VC源代码请见：http://www.driverdevelop.com/lu0/App/2k1103.html