主题：枚举计算机所有磁盘(包括移动硬盘和U盘)的信息
joforn
[专家分：1460] 发布于 2008-10-31 18:35:00
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 VB.CommandButton 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@sohu.com ******************************************
'******************** 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
'未完接下
最后更新于：2008-11-03 19:12:00
回复列表 （共9个回复）
沙发
joforn [专家分：1460] 发布于 2008-10-31 18:44:00
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
板凳
joforn [专家分：1460] 发布于 2008-10-31 18:45:00
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
3 楼
joforn [专家分：1460] 发布于 2008-10-31 18:46:00
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
4 楼
joforn [专家分：1460] 发布于 2008-10-31 18:46:00
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
5 楼
joforn [专家分：1460] 发布于 2008-10-31 19:22:00
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
6 楼
joforn [专家分：1460] 发布于 2008-10-31 19:24:00
所有代码发放完毕。
7 楼
一江秋水 [专家分：9680] 发布于 2008-10-31 20:09:00
天，这么长，作为附件发就更好了
8 楼
一江秋水 [专家分：9680] 发布于 2008-11-01 08:24:00
刚才试了一下，不能运行啊，先是API函数SetupDiGetClassDevs没有定义，我定义后再运行又是VarPtr的ByRef的参数类型不符
9 楼
joforn [专家分：1460] 发布于 2008-11-03 19:18:00
[quote]天，这么长，作为附件发就更好了[/quote]
呵，前几天我家的网络不稳定，一直传不上。现在传上来了，在一楼。
我来回复
您所在位置：