emundisk.frm

转载 EnumDisk.VB版的 转载 EnumDisk.VB版的

    PrintDataBuffer PSPTWB.DataBuf, PSPTWB.SPT.DataTransferLength
    DebugPrint 3, "************ End with PSPTWB.DataBuf *************"
    Call DebugPrint(3, "")
  End If
End Sub

Private Sub PrintSenseInfo(PSPTWB As SCSI_PASS_THROUGH_WITH_BUFFERS)
  Dim I As Integer, Str1 As String
  
  Call DebugPrint(1, "Scsi status: " & FormatHex(PSPTWB.SPT.ScsiStatus, 2))
  Call DebugPrint(1, "")
  If PSPTWB.SPT.SenseInfoLength Then
    Call DebugPrint(3, "Sense Info -- consult SCSI spec for details")
    Call DebugPrint(3, "-------------------------------------------------------------")
    For I = 0 To PSPTWB.SPT.SenseInfoLength - 1
      Str1 = Str1 & FormatHex(PSPTWB.SenseBuf(I), 2) & " "
    Next
    Call DebugPrint(3, Str1)
    Call DebugPrint(3, "")
  End If
End Sub

Private Sub PrintDataBuffer(DataBuffer() As Byte, ByVal Lenght As Long)
  Dim cnt As Long, Str1 As String
  
  Call DebugPrint(3, "       00  01  02  03  04  05  06  07   08  09  0A  0B  0C  0D  0E  0F")
  Call DebugPrint(3, "---------------------------------------------------------------------------")
  
  For cnt = 0 To Lenght - 1
    If cnt Mod 16 = 0 Then Str1 = " " & FormatHex(cnt, 4) & ": "
    Str1 = Str1 & FormatHex(DataBuffer(cnt), 2) & "  "
    If ((cnt + 1) Mod 8 = 0) And ((cnt + 1) Mod 16 <> 0) Then
      Mid(Str1, Len(Str1), 1) = "-"
      Str1 = Str1 & " "
    ElseIf (cnt + 1) Mod 16 = 0 Then
      Call DebugPrint(3, Str1)
      Str1 = vbNullString
    End If
  Next
  If Len(Str1) Then Call DebugPrint(3, Str1)
  Call DebugPrint(3, "")
End Sub

Private Sub DebugPrint(ByVal DebugPrintLevel As Long, ByVal DebugMessage As String)
  Dim I As Long
  I = InStr(DebugMessage, vbNullChar)
  If I Then DebugMessage = Mid(DebugMessage, 1, I - 1)
  If DebugPrintLevel <= DebugLevel Then List1.AddItem DebugMessage
End Sub

Private Function GetErrorStr(ByVal ErrorCode As Long, Optional ByVal OutCode As Boolean = True) As String
  Dim Buffer() As Byte
  Dim I As Long
  
  ReDim Buffer(1024)
  I = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, 0&, ErrorCode, 0&, ByVal VarPtr(Buffer(0)), 1024, 0&)
  If I Then
    ReDim Preserve Buffer(I - 1)
    GetErrorStr = IIf(OutCode, "0x" & FormatHex(ErrorCode, 4) & " - ", vbNullString) & StrConv(Buffer, vbUnicode)
  End If
End Function

'获取设备属性信息，希望得到系统中所安装的各种固定的和可移动的硬盘、优盘和CD/DVD-ROM/R/W的接口类型、序列号、产品ID等信息。
'Private Function IOCTL_STORAGE_QUERY_PROPERTY() As Long
'    IOCTL_STORAGE_QUERY_PROPERTY = CTL_CODE(IOCTL_STORAGE_BASE, &H500, METHOD_BUFFERED, FILE_ANY_ACCESS)
'End Function

'Private Function CTL_CODE(ByVal lDeviceType As Long, ByVal lFunction As Long, ByVal lMethod As Long, ByVal lAccess As Long) As Long
'    CTL_CODE = (lDeviceType * 2 ^ 16&) Or (lAccess * 2 ^ 14&) Or (lFunction * 2 ^ 2) Or (lMethod)
'End Function

'从字符缓冲中取一段数据转换成字符串
Private Function GetSTRbyBuff(ByRef Buffer() As Byte, Optional ByVal StartIndex As Long, Optional EndIndex As Long = -1, Optional ByVal ReturnFor0 As Boolean = True)
  Dim I As Long, DataByte() As Byte
  
  I = UBound(Buffer)
  If EndIndex = -1 Then
    EndIndex = I
  ElseIf I < EndIndex Then
    EndIndex = I
  End If
  If StartIndex < LBound(Buffer) Then StartIndex = LBound(Buffer)
  I = EndIndex - StartIndex
  If I >= 0 Then
    ReDim DataByte(I)
    For I = 0 To UBound(DataByte)
      If ReturnFor0 And Buffer(I + StartIndex) = 0 Then
        ReDim Preserve DataByte(I - 1)
        Exit For
      End If
      DataByte(I) = Buffer(I + StartIndex)
    Next
    GetSTRbyBuff = StrConv(DataByte, vbUnicode)
  End If
End Function

Private Function FormatHex(ByVal Num1 As Long, Optional ByVal Lenght As Long) As String
  Dim Str1 As String
  Dim I As Long
  Str1 = Hex(Num1)
  I = Len(Str1)
  If Lenght > 0 Then
    If I < Lenght Then
      Str1 = String(Lenght - I, "0") & Str1
    End If
  End If
  FormatHex = Str1
End Function

Private Function BuffertoType(ByRef Destination As STORAGE_ADAPTER_DESCRIPTOR, ByRef Sourece() As Byte) As Boolean
  Dim I As Long
  
  I = LenB(Destination)
  If UBound(Sourece) >= I - 1 Then
    CopyMemory ByVal VarPtr(Destination), ByVal VarPtr(Sourece(0)), I
    BuffertoType = True
'  Else
'    Debug.Print "空间不足"
  End If
End Function

Private Function BuffertoTypeDEVICE(ByRef Destination As STORAGE_DEVICE_DESCRIPTOR, ByRef Sourece() As Byte) As Boolean
  Dim I As Long
  
  I = LenB(Destination)
  If UBound(Sourece) >= I - 1 Then
    CopyMemory ByVal VarPtr(Destination), ByVal VarPtr(Sourece(0)), I
    BuffertoTypeDEVICE = True
  Else
    Debug.Print "空间不足"
  End If
End Function

'获取驱动器总线类型
Public Function GetDriveBusType(ByVal BusType As Long) As String
  Select Case BusType
    Case BusType1394:    GetDriveBusType = "1394"
    Case BusTypeAta:     GetDriveBusType = "ATA"
    Case BusTypeAtapi:   GetDriveBusType = "ATAPI"
    Case BusTypeFibre:   GetDriveBusType = "Fibre"
    Case BusTypeRAID:    GetDriveBusType = "RAID"
    Case BusTypeScsi:    GetDriveBusType = "SCSI"
    Case BusTypeSsa:     GetDriveBusType = "SSA"
    Case BusTypeUsb:     GetDriveBusType = "USB"
    Case BusTypeUnknown: GetDriveBusType = "Unknown"
    Case Else:           GetDriveBusType = "Unknown"
  End Select
End Function

Private Sub Form_Load()
  'DiskClassGuid = {0x53f56307L, 0xb6bf, 0x11d0, {0x94, 0xf2, 0x00, 0xa0 , 0xc9, 0x1e, 0xfb,0x8b)};.
  DiskClassGuid.Data1 = &H53F56307
  DiskClassGuid.Data2 = &HB6BF
  DiskClassGuid.Data3 = &H11D0
  DiskClassGuid.Data4(0) = &H94
  DiskClassGuid.Data4(1) = &HF2
  DiskClassGuid.Data4(2) = &H0
  DiskClassGuid.Data4(3) = &HA0
  DiskClassGuid.Data4(4) = &HC9
  DiskClassGuid.Data4(5) = &H1E
  DiskClassGuid.Data4(6) = &HFB
  DiskClassGuid.Data4(7) = &H8B
  
  GUID_DEVCLASS_DISKDRIVE.Data1 = &H4D36E967
  GUID_DEVCLASS_DISKDRIVE.Data2 = &HE325
  GUID_DEVCLASS_DISKDRIVE.Data3 = &H11CE
  GUID_DEVCLASS_DISKDRIVE.Data4(0) = &HBF
  GUID_DEVCLASS_DISKDRIVE.Data4(1) = &HC1
  GUID_DEVCLASS_DISKDRIVE.Data4(2) = &H8
  GUID_DEVCLASS_DISKDRIVE.Data4(3) = &H0
  GUID_DEVCLASS_DISKDRIVE.Data4(4) = &H2B
  GUID_DEVCLASS_DISKDRIVE.Data4(5) = &HE1
  GUID_DEVCLASS_DISKDRIVE.Data4(6) = &H3
  GUID_DEVCLASS_DISKDRIVE.Data4(7) = &H18
  
  DeviceType() = Split("Direct Access Device,Tape Device,Printer Device,Processor Device," & _
                     "WORM Device,CDROM Device,Scanner Device,Optical Disk,Media Changer," & _
                     "Comm. Device,ASCIT8,ASCIT8,Array Device,Enclosure Device," & _
                     "RBC Device,Unknown Device", ",")
  Command1.Caption = "&EnumDisk"
End Sub

Private Sub Command1_Click()
    Dim hDevInfo As Long, hIntDevInfo As Long, Index As Long
    Dim Status As Boolean
    
    List1.Clear
    
    hDevInfo = SetupDiGetClassDevs(VarPtr(GUID_DEVCLASS_DISKDRIVE), 0&, 0&, DIGCF_PRESENT)
    If hDevInfo = INVALID_HANDLE_VALUE Then
      DebugPrint 1, "SetupDiGetClassDevs failed with error:" & GetLastError
      Exit Sub
    End If
    
    hIntDevInfo = SetupDiGetClassDevs(VarPtr(DiskClassGuid), 0&, 0&, DIGCF_PRESENT Or DIGCF_INTERFACEDEVICE)
    If hIntDevInfo = INVALID_HANDLE_VALUE Then
      DebugPrint 1, "SetupDiGetClassDevs failed with error:" & GetLastError
      Exit Sub
    End If
    
    Do
      DebugPrint 1, "Properties for Device " & Index + 1
      DebugPrint 1, ""
      Status = GetRegistryProperty(hDevInfo, Index)
      If Status Then
        Status = GetDeviceProperty(hIntDevInfo, Index)
        If Status Then
          Index = Index + 1
        Else
          Exit Do
        End If
      Else
        Exit Do
      End If
    Loop While True
    With List1
      .List(.ListCount - IIf(DebugLevel > 1, 3, 2)) = " ***  End of Device List  *** "
      .RemoveItem .ListCount - 1
    End With
    SetupDiDestroyDeviceInfoList hDevInfo
    SetupDiDestroyDeviceInfoList hIntDevInfo
End Sub

Private Sub Form_Resize()
  On Error Resume Next
  Command1.Left = (Me.ScaleWidth - Command1.Width) \ 2
  List1.Width = Me.ScaleWidth - List1.Left * 2
  List1.Height = Me.ScaleHeight - List1.Top - 100
End Sub

Private Sub List1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = 2 Then
    With List1
      If .ListCount Then Me.PopupMenu File, , X + .Left + 100, Y + .Top - 10
    End With
  End If
End Sub

Private Sub SavetoText_Click()
  Dim FileName As String
  Dim FileL As Long
  Dim Str1 As String
  Dim I As Long
  
  On Error Resume Next
  
  FileName = InputBox("请输入一个文件名：", "保存到文件...", "DiskList")
  If Len(FileName) Then
    FileL = FreeFile
    With List1
      For I = 0 To .ListCount - 2
        Str1 = Str1 & .List(I) & vbCrLf
      Next
      If Len(.List(.ListCount - 1)) Then Str1 = Str1 & .List(.ListCount - 1)
      If InStr(FileName, ":") = 0 Then FileName = App.Path & IIf(Right(App.Path, 1) = "\", vbNullString, "\") & FileName & ".TXT"
      If Dir(FileName) Then Kill FileName
      Open FileName For Binary As FileL
      Put FileL, , Str1
      Close FileL
    End With
  End If
End Sub