VB版EnumDisk
[free]EnumDisk是一个枚举计算机所有磁盘(包括移动硬盘和U盘)的信息。不过网上只有C的。花了好几天的时间把C的改成了VB版的。主要的时间花在了重新定义几个关键的Type，因为好多Type直译过来后出现了“水土不服”。主要的原因是有些C中的数据类型长度与VB中的长度不一致，还有一些是MSDN或是网上搜来的C结构定义和实际在调用时的定义也有不一样的，但问题出在哪我也不敢瞎猜。
这个程序可以列出机器中所有磁盘的主要信息：PID、VID、SN、厂商、版本等信息，包括SCSI硬盘的。
但是在调试中也发现了一点问题：比如说ProductIdOffset、VendorIdOffset等数据在有些机器上返回的数据并不是真正的数据所在的偏移地址(数据确时返回了，但就是偏移地址不对)。这个问题在网上也没有搜到相关的信息，原想通过一定的计算来重定位这一类的偏移，但最后调试中发现，在不同的机器上偏移的误差并不一样，只好作罢。这个问题就留给大家自己去找解决方法吧。
下载说明：把下面的代码保存到文本文件，将文件名后缀改成.FRM就可以了。
[/free]
程序代码：VERSION 5.00
Begin VB.Form FormMain
Caption = "Form1"
ClientHeight = 4545
ClientLeft = 60
ClientTop = 450
ClientWidth = 9435
LinkTopic = "Form1"
ScaleHeight = 4545
ScaleWidth = 9435
StartUpPosition = 3 '窗口缺省
Begin Command1
Caption = "Command1"
Height = 375
Left = 3870
TabIndex = 1
Top = 90
Width = 1275
End
Begin VB.ListBox List1
Height = 3840
Left = 135
TabIndex = 0
Top = 540
Width = 9165
End
Begin VB.Menu File
Caption = "&File"
Visible = 0 'False
Begin VB.Menu SavetoText
Caption = "保存到文件(&S)"
End
End
End
Attribute VB_Name = "FormMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'*************************************************************************************************
'******************** 作者： 南宫飘雪 ******************************************
'******************** Email: Joforn@ ******************************************
'******************** QQ: 42978116 ******************************************
'*************************************************************************************************
'查询存储设备属性的类型
Private Enum STORAGE_QUERY_TYPE
PropertyStandardQuery = 0 '读取描述
PropertyExistsQuery '测试是否支持
PropertyMaskQuery '读取指定的描述
PropertyQueryMaxDefined '验证数据
End Enum
'存储设备的总线类型
Private Enum STORAGE_BUS_TYPE
BusTypeUnknown = 0&
BusTypeScsi
BusTypeAtapi
BusTypeAta
BusType1394
BusTypeSsa
BusTypeFibre
BusTypeUsb
BusTypeRAID
BusTypeMaxReserved = &H7F
End Enum
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type SP_DEVICE_INTERFACE_DETAIL_DATA
cbSize As Long
DevicePath As String * 260
End Type
Private Type SP_DEVICE_INTERFACE_DATA
cbSize As Long 'taille de la structure en octets
InterfaceClassGuid As GUID 'GUID de la classe d'interface
Flags As Long 'options
Reserved As Long 'réservé
End Type
Private Type SP_DEVINFO_DATA
cbSize As Long 'taille de la structure en octets
ClassGuid As GUID 'GUID de la classe d'installation
DevInst As Long 'handle utilisable par certaine fonction CM_xxx
Reserved As Long 'réservé
End Type
Private Type STORAGE_DEVICE_NUMBER
dwDeviceType As Long
dwDeviceNumber As Long
dwPartitionNumber As Long
End Type
'Private Type OVERLAPPED
' Internal As Long '保留给操作系统使用。用于保存系统状态，当GetOverLappedRseult的返回值中没有设置ERROR_IO_PENDING时，本域为有效。
' InternalHigh As Long '成员保留给操作系统使用。用于保存异步传输数据的长度。当GetOverLappedRseult返回TRUE时，本域为有效。
' offset As Long '指定开始进行异步传输的文件的一个位置。该位置是距离文件开头处的偏移值。在调用ReadFile或WriteFile之前，必须设置此分量。
' OffsetHigh As Long '指定开始异步传输处的字节偏移的高位字部分。
' hEvent As Long '指向一个事件的句柄，当传输完后将其设置为信号状态。
'End Type
Private Type STORAGE_ADAPTER_DESCRIPTOR
Version As Long
Size As Long
MaximumTransferLength As Long
MaximumPhysicalPages As Long
AlignmentMask As Long
AdapterUsesPio As Byte 'As Boolean
AdapterScansDown As Byte 'As Boolean
CommandQueueing As Byte 'As Boolean
AcceleratedTransfer As Byte 'As Boolean
BusType As Byte 'As STORAGE_BUS_TYPE
BusMajorVersion As Integer
BusMinorVersion As Integer
End Type
'查询存储设备还是适配器属性
Private Enum STORAGE_PROPERTY_ID
StorageDeviceProperty = 0& '查询设备属性
StorageAdapterProperty '查询适配器属性
End Enum
'查询属性输入的数据结构
Private Type STORAGE_PROPERTY_QUERY
PropertyId As Integer 'As STORAGE_PROPERTY_ID '设备/适配器
QueryType As Integer 'As STORAGE_QUERY_TYPE '查询类型
AdditionalParameters(7) As Byte '额外的数据(仅定义了象徵性的1个字节)
End Type
'查询属性输出的数据结构
Private Type STORAGE_DEVICE_DESCRIPTOR
Version As Long '版本
Size As Long '结构大小
DeviceType As Byte '设备类型
DeviceTypeModifier As Byte 'SCSI-2额外的设备类型
RemovableMedia As Byte '是否可移动(原类型为BOOLEAN)
CommandQueueing As Byte '是否支持命令队列(原类型为BOOLEAN)
VendorIdOffset As Long '厂家设定值的偏移
ProductIdOffset As Long '产品ID的偏移
ProductRevisionOffset As Long '产品版本的偏移
SerialNumberOffset As Long '序列号的偏移
BusType As Long '总线类型(原类型为Integer)
RawPropertiesLength As Long '额外的属性数据长度
RawDeviceProperties(0) As Byte '额外的属性数据(仅定义了象徵性的1个字节)
End Type
Private Type SCSI_PASS_THROUGH
Length As Integer
ScsiStatus As Byte
PathId As Byte
TargetId As Byte
Lun As Byte
CdbLength As Byte
SenseInfoLength As Byte
DataIn As Long
DataTransferLength As Long
TimeOutValue As Long
DataBufferOffset As Long
SenseInfoOffset As Long
Cdb(15) As Byte
End Type
Private Type SCSI_PASS_THROUGH_WITH_BUFFERS
SPT As SCSI_PASS_THROUGH
Filler As Long
SenseBuf(32) As Byte
DataBuf(512) As Byte
End Type
Private Enum PNP_VETO_TYPE
PNP_VetoTypeUnknown
PNP_VetoLegacyDevice
PNP_VetoPendingClose
PNP_VetoWindowsApp
PNP_VetoWindowsService
PNP_VetoOutstandingOpen
PNP_VetoDevice
PNP_VetoDriver
PNP_VetoIllegalDeviceRequest
PNP_VetoInsufficientPower
PNP_VetoNonDisableable
PNP_VetoLegacyDriver
PNP_VetoInsufficientRights
End Enum
Private Const DebugLevel = 1
Private Const IntDevicePathLenght = 512
'Private Const DIGCF_DEFAULT = &H1 ' only valid with DIGCF_DEVICEINTERFACE
Private Const DIGCF_PRESENT = &H2
'Private Const DIGCF_ALLCLASSES = &H4
'Private Const DIGCF_PROFILE = &H8
Private Const DIGCF_DEVICEINTERFACE = &H10
Private Const DIGCF_INTERFACEDEVICE = 16
Private Const GENERIC_READ = &H80000000 '允许对设备进行读访问
Private Const GENERIC_WRITE = &H40000000 '允许对设备进行写访问
Private Const FILE_SHARE_READ = &H1 '允许读取共享
Private Const OPEN_EXISTING = 3 '文件必须已经存在。由设备提出要求
Private Const FILE_SHARE_WRITE = &H2 '允许对文件进行共享访问
Private Const IOCTL_STORAGE_BASE = &H2D&
Private Const METHOD_BUFFERED = 0&
Private Const FILE_ANY_ACCESS = 0&
Private Const FILE_READ_ACCESS = 1&
Private Const FILE_WRITE_ACCESS = 2&
Private Const CDB6GENERIC_LENGTH As Byte = 6
Private Const CDB10GENERIC_LENGTH As Byte = 10
Private Const SCSI_IOCTL_DATA_OUT As Byte = 0
Private Const SCSI_IOCTL_DATA_IN As Byte = 1
Private Const SCSI_IOCTL_DATA_UNSPECIFIED = 2
Private Const IOCTL_SCSI_PASS_THROUGH = &H4D004
Private Const IOCTL_STORAGE_QUERY_PROPERTY = &H2D1400
Private Const SCSIOP_INQUIRY = &H12&
Private Const ERROR_INVALID_DATA = 13&
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const ERROR_INSUFFICIENT_BUFFER = 122&
Private Const INVALID_HANDLE_VALUE = -1&
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Declare Function SetupDiEnumDeviceInfo Lib "setupapi.dll" (ByVal DeviceInfoSet As Long, ByVal MemberIndex As Long, ByRef DeviceInfoData As SP_DEVINFO_DATA) As Boolean
Private Declare Function SetupDiGetDeviceRegistryProperty Lib "setupapi" Alias "SetupDiGetDeviceRegistryPropertyA" (ByVal DeviceInfoSet As Long, DeviceInfoData As SP_DEVINFO_DATA, ByVal Property As Long, ByRef PropertyRegDataType As Long, ByVal PropertyBuffer As Long, ByVal PropertyBufferSize As Long, RequiredSize As Long) As Long
Private Const SPDRP_DEVICEDESC As Long = (&H0) '// DeviceDesc (R/W)
Private Const SPDRP_HARDWAREID As Long = (&H1) '// HardwareID (R/W)
Private Const SPDRP_COMPATIBLEIDS As Long = (&H2) '// CompatibleIDs (R/W)
Private Const SPDRP_UNUSED0 As Long = (&H3) '// unused
Private Const SPDRP_SERVICE As Long = (&H4) '// Service (R/W)
Private Const SPDRP_UNUSED1 As Long = (&H5) '// unused
Private Const SPDRP_UNUSED2 As Long = (&H6) '// unused
Private Const SPDRP_CLASS As Long = (&H7) '// Class (R--tied to ClassGUID)
Private Const SPDRP_CLASSGUID As Long = (&H8) '// ClassGUID (R/W)
Private Const SPDRP_DRIVER As Long = (&H9) '// Driver (R/W)
Private Const SPDRP_CONFIGFLAGS As Long = (&HA) '// ConfigFlags (R/W)
Private Const SPDRP_MFG As Long = (&HB) '// Mfg (R/W)
Private Const SPDRP_FRIENDLYNAME As Long = (&HC) '// FriendlyName (R/W)
Private Const SPDRP_LOCATION_INFORMATION As Long = (&HD) '// LocationInformation (R/W)
Private Const SPDRP_PHYSICAL_DEVICE_OBJECT_NAME As Long = (&HE) '// PhysicalDeviceObjectName (R)
Private Const SPDRP_CAPABILITIES As Long = (&HF) '// Capabilities (R)
Private Const SPDRP_UI_NUMBER As Long = (&H10) '// UiNumber (R)
Private Const SPDRP_UPPERFILTERS As Long = (&H11) '// UpperFilters (R/W)
Private Const SPDRP_LOWERFILTERS As Long = (&H12) '// LowerFilters (R/W)
Private Const SPDRP_BUSTYPEGUID As Long = (&H13) '// BusTypeGUID (R)
Private Const SPDRP_LEGACYBUSTYPE As Long = (&H14) '// LegacyBusType (R)
Private Const SPDRP_BUSNUMBER As Long = (&H15) '// BusNumber (R)
Private Const SPDRP_ENUMERATOR_NAME As Long = (&H16) '// Enumerator Name (R)
Private Const SPDRP_SECURITY As Long = (&H17) '// Security (R/W, binary form)
Private Const SPDRP_SECURITY_SDS As Long = (&H18) '// Security (W, SDS form)
Private Const SPDRP_DEVTYPE As Long = (&H19) '// Device Type (R/W)
Private Const SPDRP_EXCLUSIVE As Long = (&H1A) '// Device is exclusive-access (R/W)
Private Const SPDRP_CHARACTERISTICS As Long = (&H1B) '// Device Characteristics (R/W)
Private Const SPDRP_ADDRESS As Long = (&H1C) '// Device Address (R)
Private Const SPDRP_UI_NUMBER_DESC_FORMAT As Long = (&H1D) '// UiNumberDescFormat (R/W)
Private Const SPDRP_DEVICE_POWER_DATA As Long = (&H1E) '// Device Power Data (R)
Private Const SPDRP_REMOVAL_POLICY As Long = (&H1F) '// Removal Policy (R)
Private Const SPDRP_REMOVAL_POLICY_HW_DEFAULT As Long = (&H20) '// Hardware Removal Policy (R)
Private Const SPDRP_REMOVAL_POLICY_OVERRIDE As Long = (&H21) '// Removal Policy Override (RW)
Private Const SPDRP_INSTALL_STATE As Long = (&H22) '// Device Install State (R)
Private Const SPDRP_MAXIMUM_PROPERTY As Long = (&H23) '// Upper bound on ordinals
'Private Declare Function SetupDiEnumDeviceInfo Lib "setupapi" (ByVal DeviceInfoSet As Long, ByVal MemberIndex As Long, DeviceInfoData As SP_DEVINFO_DATA) As Long
Private Declare Function SetupDiGetClassDevs Lib "setupapi.dll" Alias "SetupDiGetClassDevsA" (ByVal ClassGuid As Long, ByVal Enumerator As Long, ByVal HwndParent As Long, ByVal Flags As Long) As Long
Private Declare Function SetupDiEnumDeviceInterfaces Lib "setupapi.dll" (ByVal DeviceInfoSet As Long, ByVal DeviceInfoData As Long, ByRef InterfaceClassGuid As GUID, ByVal MemberIndex As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA) As Long
Private Declare Function SetupDiGetDeviceInterfaceDetail Lib "setupapi.dll" Alias "SetupDiGetDeviceInterfaceDetailA" (ByVal DeviceInfoSet As Long, ByRef DeviceInterfaceData As SP_DEVICE_INTERFACE_DATA, DeviceInterfaceDetailData As Any, ByVal DeviceInterfaceDetailDataSize As Long, ByRef RequiredSize As Long, DeviceInfoData As Any) As Long
Private Declare Function SetupDiDestroyDeviceInfoList Lib "setupapi.dll" (ByVal DeviceInfoSet As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CM_Get_Parent Lib "cfgmgr32.dll" (pdwDevInst As Long, ByVal dwDevInst As Long, ByVal ulFlags As Long) As Long
Private Declare Function CM_Request_Device_EjectW Lib "setupapi.dll" (ByVal dwDevInst As Long, ByVal pVetoType As Long, ByVal pszVetoName As String, ByVal ulNameLength As Long, ByVal ulFlags As Long) As Long
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 Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Declare Function QueryDosDevice Lib "kernel32" Alias "QueryDosDeviceA" (ByVal lpDeviceName As String, ByVal lpTargetPath As String, ByVal ucchMax As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As Any, ByVal nSize As Long, Arguments As Long) As Long
Private DiskClassGuid As GUID
Private GUID_DEVCLASS_DISKDRIVE As GUID
Private DeviceType() As String
Private DriveBusType() As String
Private Function GetRegistryProperty(ByVal DevInfo As Long, ByVal Index As Long) As Boolean
Dim DeviceInfoData As SP_DEVINFO_DATA
Dim ErrorCode As Long, BufferSize As Long, DataType As Long
Dim Buffer() As Byte
Dim Status As Boolean
DeviceInfoData.cbSize = Len(DeviceInfoData)
Status = SetupDiEnumDeviceInfo(DevInfo, Index, DeviceInfoData)
If Status Then
Status = SetupDiGetDeviceRegistryProperty(DevInfo, DeviceInfoData, SPDRP_HARDWAREID, DataType, 0&, BufferSize, BufferSize)
ErrorCode = GetLastError
If Status = False And (BufferSize = 0) Then
If ErrorCode <> ERROR_INSUFFICIENT_BUFFER Then
If ErrorCode = ERROR_INVALID_DATA Then
GetRegistryProperty = True: Exit Function
Else
Call DebugPrint(1, "SetupDiGetDeviceInterfaceDetail failed with error: " & GetErrorStr(ErrorCode))
Exit Function
End If
End If
End If
If BufferSize <= 0 Then Exit Function
ReDim Buffer(BufferSize)
Status = SetupDiGetDeviceRegistryProperty(DevInfo, DeviceInfoData, SPDRP_HARDWAREID, DataType, VarPtr(Buffer(0)), BufferSize, BufferSize)
If Status Then
DebugPrint 1, "Device ID: " & StrConv(Buffer, vbUnicode)
Else
ErrorCode = GetLastError
If ErrorCode <> ERROR_INVALID_DATA Then
DebugPrint 1, "SetupDiGetDeviceInterfaceDetail failed with error:" & GetErrorStr(ErrorCode)
Exit Function
End If
End If
GetRegistryProperty = True
Else
ErrorCode = GetLastError()
If ErrorCode = ERROR_NO_MORE_ITEMS Then
DebugPrint 2, "No more devices."
Else
DebugPrint 1, "SetupDiEnumDeviceInfo failed with error: " & GetErrorStr(ErrorCode)
End If
End If
End Function
Private Function GetDeviceProperty(ByVal IntDevInfo As Long, ByVal Index As Long) As Boolean
'routine Description:
' This routine enumerates the disk devices using the Device interface
' GUID DiskClassGuid. Gets the Adapter & Device property from the port
' driver. Then sends IOCTL through SPTI to get the device Inquiry data.
'
'Arguments:
' IntDevInfo - Handles to the interface device information list'
' Index - Device member
'
'Return Value:
'
' TRUE / FALSE. This decides whether to continue or not
Dim interfaceData As SP_DEVICE_INTERFACE_DATA
Dim interfaceDetailData As SP_DEVICE_INTERFACE_DETAIL_DATA
Dim Query As STORAGE_PROPERTY_QUERY
Dim adpDesc As STORAGE_ADAPTER_DESCRIPTOR
Dim devDesc As STORAGE_DEVICE_DESCRIPTOR
Dim SPTWB As SCSI_PASS_THROUGH_WITH_BUFFERS
Dim hDevice As Long
Dim Status As Boolean
Dim P As String
Dim OutBuf(0 To 1024) As Byte
Dim Length As Long
Dim Returned As Long
Dim ReturnedLength As Long
Dim interfaceDetailDataSize As Long
Dim reqSize As Long
Dim ErrorCode As Long
Dim I As Long
On Error Resume Next
interfaceData.cbSize = Len(interfaceData)
Status = SetupDiEnumDeviceInterfaces(IntDevInfo, 0&, DiskClassGuid, Index, interfaceData)
If Not Status Then
ErrorCode = GetLastError()
If ErrorCode = ERROR_NO_MORE_ITEMS Then
Call DebugPrint(2, "No more interfaces")
Else
Call DebugPrint(1, "SetupDiEnumDeviceInterfaces failed with error:" & GetErrorStr(ErrorCode))
End If
End If
Status = SetupDiGetDeviceInterfaceDetail(IntDevInfo, interfaceData, ByVal 0&, 0&, reqSize, ByVal 0&)
' 这一段是按C的格式直接译过来的，但必须注销，因为VB在调用GetLastError前似乎自动清掉了错误提示，
' 所以GetLastError取不到错误码(GetLastError返回0)？？？但是这种情况是在编译后发生的，在调试状态下却是能正常得到错误码。
' If Status = False Then
' ErrorCode = GetLastError
' If (ErrorCode <> ERROR_INSUFFICIENT_BUFFER) Then
' Call DebugPrint(1, "SetupDiGetDeviceInterfaceDetail failed with error: " & GetErrorStr(ErrorCode))
' Exit Function
' End If
' End If
interfaceDetailDataSize = reqSize
If Len(interfaceDetailData.DevicePath) < interfaceDetailDataSize Then
Call DebugPrint(1, "Unable to allocate memory to get the interface detail data.")
Exit Function
End If
interfaceDetailData.cbSize = 5
reqSize = 0
Status = SetupDiGetDeviceInterfaceDetail(IntDevInfo, interfaceData, interfaceDetailData, interfaceDetailDataSize, reqSize, ByVal 0&)
If Not Status Then
Call DebugPrint(1, "Error in SetupDiGetDeviceInterfaceDetail failed with error: " & GetErrorStr(ErrorCode))
Exit Function
End If
Call DebugPrint(2, "Interface: " & interfaceDetailData.DevicePath)
I = InStr(interfaceDetailData.DevicePath, vbNullChar)
P = IIf(I, Mid(interfaceDetailData.DevicePath, 1, I), interfaceDetailData.DevicePath)
hDevice = CreateFile(P, _
GENERIC_READ Or GENERIC_WRITE, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, _
ByVal 0&, _
OPEN_EXISTING, _
0&, _
0&)
If hDevice = INVALID_HANDLE_VALUE Then
Call DebugPrint(1, "CreateFile failed with error: " & GetErrorStr(GetLastError))
GetDeviceProperty = True
Exit Function
End If
Query.PropertyId = StorageAdapterProperty
Query.QueryType = PropertyStandardQuery
adpDesc.Size = Len(adpDesc)
Status = DeviceIoControl(hDevice, IOCTL_STORAGE_QUERY_PROPERTY, Query, Len(Query), ByVal VarPtr(OutBuf(0)), 512, ReturnedLength, ByVal 0&)
If Not Status Then
Call DebugPrint(1, "IOCTL failed with error code: " & GetErrorStr(GetLastError))
Else
GetDeviceProperty = True
If BuffertoType(adpDesc, OutBuf()) = False Then
Call DebugPrint(1, "BuffertoType CopyMemory failed with error : Not enough space.")
End If
' PrintDataBuffer OutBuf, ReturnedLength
Call DebugPrint(1, vbNullString)
Call DebugPrint(1, "Adapter Properties")
Call DebugPrint(1, "------------------")
Call DebugPrint(1, "Bus Type : " & GetDriveBusType(adpDesc.BusType))
Call DebugPrint(1, "Max. Tr. Length: 0x" & FormatHex(adpDesc.MaximumTransferLength, 2))
Call DebugPrint(1, "Max. Phy. Pages: 0x" & FormatHex(adpDesc.MaximumPhysicalPages, 2))
Call DebugPrint(1, "Alignment Mask : 0x" & FormatHex(adpDesc.AlignmentMask, 2))
Query.PropertyId = StorageDeviceProperty
Query.QueryType = PropertyStandardQuery
devDesc.Size = Len(devDesc)
Status = DeviceIoControl(hDevice, IOCTL_STORAGE_QUERY_PROPERTY, Query, Len(Query), ByVal VarPtr(OutBuf(0)), 512, ReturnedLength, ByVal 0&)
If Not Status Then
Call DebugPrint(1, "IOCTL failed with error code: " & GetErrorStr(GetLastError))
Else
DebugPrint 3, "OutBuf Data"
PrintDataBuffer OutBuf, ReturnedLength
Call DebugPrint(1, vbNullString)
Call DebugPrint(1, "Device Properties")
Call DebugPrint(1, "-----------------")
If BuffertoTypeDEVICE(devDesc, OutBuf()) = False Then
Call DebugPrint(1, "BuffertoTypeDEVICE CopyMemory failed with error : Not enough space.")
End If
Call DebugPrint(1, "Device Type : " & DeviceType(IIf(devDesc.DeviceType < &H10, devDesc.DeviceType, &HF)) & " (0x" & FormatHex(devDesc.DeviceType, 2) & ")")
If devDesc.DeviceTypeModifier Then Call DebugPrint(1, "Device Modifier : 0x" & Hex(devDesc.DeviceTypeModifier))
Call DebugPrint(1, "Removable Media : " & IIf(devDesc.RemovableMedia, "Yes", "No"))
With devDesc
If .VendorIdOffset Then
Call DebugPrint(1, "Vendor ID : " & GetSTRbyBuff(OutBuf, .VendorIdOffset, ReturnedLength))
End If
If .ProductIdOffset Then
Call DebugPrint(1, "Product ID : " & GetSTRbyBuff(OutBuf, .ProductIdOffset, ReturnedLength))
End If
If .ProductRevisionOffset Then
Call DebugPrint(1, "Product Revision: " & GetSTRbyBuff(OutBuf, .ProductRevisionOffset, ReturnedLength))
End If
If .SerialNumberOffset Then
Call DebugPrint(1, "Serial Number : " & GetSTRbyBuff(OutBuf, .SerialNumberOffset, ReturnedLength))
End If
End With
End If
End If
SPTWB.SPT.Length = Len(SPTWB.SPT)
SPTWB.SPT.PathId = 0
SPTWB.SPT.TargetId = 1
SPTWB.SPT.Lun = 0
SPTWB.SPT.CdbLength = CDB6GENERIC_LENGTH
SPTWB.SPT.SenseInfoLength = 24
SPTWB.SPT.DataIn = SCSI_IOCTL_DATA_IN
SPTWB.SPT.DataTransferLength = 192
SPTWB.SPT.TimeOutValue = 2
' // SPTWB.Spt.DataBufferOffset = offsetof(SCSI_PASS_THROUGH_WITH_BUFFERS,DataBuf);
' // SPTWB.spt.SenseInfoOffset = offsetof(SCSI_PASS_THROUGH_WITH_BUFFERS, SenseBuf)
SPTWB.SPT.SenseInfoOffset = SPTWB.SPT.Length + 4
SPTWB.SPT.DataBufferOffset = SPTWB.SPT.SenseInfoOffset + UBound(SPTWB.SenseBuf) + 1
SPTWB.SPT.Cdb(0) = SCSIOP_INQUIRY
SPTWB.SPT.Cdb(4) = &HC0
Length = SPTWB.SPT.DataBufferOffset + SPTWB.SPT.DataTransferLength
Length = Len(SPTWB)
Status = DeviceIoControl(hDevice, IOCTL_SCSI_PASS_THROUGH, SPTWB, SPTWB.SPT.Length, SPTWB, Length, Returned, ByVal 0&)
ErrorCode = GetLastError
Call DebugPrint(1, "")
Call DebugPrint(1, "Inquiry Data from Pass Through")
Call DebugPrint(1, "------------------------------")
If Status Then
PrintStatusResults Returned, SPTWB
Else
Call DebugPrint(1, "DeviceIoControl Error: " & GetErrorStr(ErrorCode))
End If
If CloseHandle(hDevice) = 0 Then Call DebugPrint(2, "Failed to close device.")
GetDeviceProperty = True
End Function
Private Sub PrintStatusResults(ByVal Returned As Long, PSPTWB As SCSI_PASS_THROUGH_WITH_BUFFERS)
Dim ErrorCode As Long, I As Integer, devType As Integer
If (PSPTWB.SPT.ScsiStatus) Then
PrintSenseInfo PSPTWB
Else
devType = PSPTWB.DataBuf(0) And &H1F
Call DebugPrint(1, "Device Type: " & DeviceType(IIf(devType > &HF, &HF, devType)) & " (0x" & Hex(devType) & ")")
If PSPTWB.DataBuf(8) Then Call DebugPrint(1, "Vendor ID : " & GetSTRbyBuff(PSPTWB.DataBuf, 8, 15, False))
If PSPTWB.DataBuf(16) Then Call DebugPrint(1, "Product ID : " & GetSTRbyBuff(PSPTWB.DataBuf, 16, 31, False))
If PSPTWB.DataBuf(32) Then Call DebugPrint(1, "Product Rev: " & GetSTRbyBuff(PSPTWB.DataBuf, 32, 35, False))
If PSPTWB.DataBuf(36) Then Call DebugPrint(1, "Vendor Str : " & GetSTRbyBuff(PSPTWB.DataBuf, 36, 55, False))
Call DebugPrint(1, "")
Call DebugPrint(3, "Scsi status: 0x" & FormatHex(PSPTWB.SPT.ScsiStatus, 2) & ", Bytes returned: 0x" & Hex(Returned))
Call DebugPrint(3, "Data buffer length: 0x" & Hex(PSPTWB.SPT.DataTransferLength))
Call DebugPrint(1, "")
DebugPrint 3, "************ Data with PSPTWB.DataBuf ************"
DebugPrint 3, ""
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
[free][bo]以上代码经过Windows XP+VB6.0测试成功。[/bo][/free]
[[it] 本帖最后由 Joforn 于 2008-10-31 18:08 编辑 [/it]]
支持一下,鼓励发布代码收取积分(就是论坛限制的积分上限太低了),虽然我对这个不感兴趣,但是也买了
说实话，我没听明白楼上你说的啥。。。。。