 Autor
|
Tema: Serial y Unidad de Pen Drive (Leído 14,524 veces)
|
Dessa
 Desconectado
Mensajes: 624
|
Paso para el que le sirva y a modo de concepto el siguiente code para relacionar los seriales de los Pendrive con sus respectivas unidades utilizando APIs, repito que es a modo de concepto y solo para XP (En W7 es mas directo ya que el serial se encuentra en el binario de HKEY_LOCAL_MACHINE\SYSTEM\MountedDevices y no hay nesecidad de enumerar las claves de USBSTOR). PD1: Si hay una manera mejor o mas directa les agradecería si la pueden compartir. PD2: Si alguien tiene claro en que casos WMI puede estar no disponible tambien lo agradecería ya que no encuentro mucho al respecto en la web. (por lo menos en español). FORMULARIO:
Option Explicit
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@ Function Datos by Dessa '@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Private Declare Function GetLogicalDrives Lib "kernel32" () As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Private Sub Form_DblClick(): Me.Print Datos: End Sub
Private Sub Form_Load()
Me.AutoRedraw = True
Me.FontBold = True
Me.Print Datos
End Sub
Private Function Datos() As String
Dim x As Long: Dim i As Long
Dim USBSTOR As String: Dim inUSBSTOR() As String
Dim Seriales As String: Dim inSeriales() As String
Dim Historial As String: Dim inHistorial() As String
Dim ingDrives() As String
Dim Unidades As String
If CheckRegistryKey(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR") = True Then
'MsgBox EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR").Count
'----------------------------------------------------------------------------------------
If EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR").Count > 0 Then
For i = 1 To EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR").Count
USBSTOR = USBSTOR + EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR").Item(i) + vbNewLine
Next i
'MsgBox USBSTOR
Else
MsgBox "No hay Unidades de USB registradas"
Exit Function
End
End If
'----------------------------------------------------------------------------------------
inUSBSTOR() = Split(USBSTOR, vbNewLine)
For x = 0 To UBound(inUSBSTOR) - 1
For i = 1 To EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR\" + inUSBSTOR(x)).Count
Seriales = Seriales + inUSBSTOR(x) + "\" + EnumRegistryKeys(&H80000002, "SYSTEM\CurrentControlSet\Enum\USBSTOR\" + inUSBSTOR(x)).Item(i) + vbNewLine
Next i
Next x
'MsgBox Seriales
'----------------------------------------------------------------------------------------
inSeriales() = Split(Seriales, vbNewLine)
Dim valor As String: Dim clave As String: Dim dato As Variant
For x = 0 To UBound(inSeriales) - 1
clave = "SYSTEM\CurrentControlSet\Enum\USBSTOR\" + inSeriales(x)
valor = "ParentIdPrefix"
dato = GetRegistryValue(&H80000002, clave, valor)
Historial = Historial + inSeriales(x) + " " + dato + vbNewLine
Next x
'MsgBox Historial
'----------------------------------------------------------------------------------------
inHistorial() = Split(Historial, vbNewLine)
ingDrives() = Split(lDrives, ":")
For x = 0 To UBound(ingDrives) - 1
For i = 0 To UBound(inHistorial) - 1
If InStr(1, inHistorial(i), Parent_Id_Prefix(ingDrives(x))) > 1 Then
Unidades = Mid(inHistorial(i), InStr(1, inHistorial(i), "\") + 1, Len(inHistorial(i)))
Unidades = Mid(Unidades, 1, InStr(1, Unidades, "&") - 1)
Datos = Datos + ingDrives(x) + ": " + Unidades + vbNewLine
End If
Next i
Next x
'MsgBox Datos
'----------------------------------------------------------------------------------------
Else
MsgBox "NO EXISTE USBSTOR, NUNCA SE CONECTARON DISPOSITIVOS USB EN ESTE EQUIPO"
End
End If
If Datos = "" Then Datos = "NO HAY DISPOSITIVOS USB CONECTADOS"
End Function
Private Function lDrives() As String
Dim LDs As Long: Dim Cnt As Long: Dim sDrives As String
LDs = GetLogicalDrives
For Cnt = 2 To 25
If (LDs And 2 ^ Cnt) <> 0 Then
If GetDriveType(Chr$(65 + Cnt) + ":\") = 2 Then
sDrives = sDrives + Chr$(65 + Cnt) + ":"
End If
End If
Next Cnt
lDrives = sDrives
End Function
MODULO1
Option Explicit
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'http://binaryworld.net/Main/ApiDetail.aspx?ApiId=32141 '@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal numBytes As Long)
Public Const KEY_READ = &H20019
Public Const KEY_ALL_ACCESS = &H3F
Const REG_SZ = 1
Const REG_EXPAND_SZ = 2
Const REG_BINARY = 3
Const REG_DWORD = 4
Const REG_MULTI_SZ = 7
Const ERROR_MORE_DATA = 234
Function GetRegistryValue(ByVal hKey As Long, ByVal KeyName As String, _
ByVal ValueName As String, Optional DefaultValue As Variant) As Variant
Dim handle As Long
Dim resLong As Long
Dim resString As String
Dim resBinary() As Byte
Dim length As Long
Dim retVal As Long
Dim valueType As Long
' Prepare the default result
GetRegistryValue = IIf(IsMissing(DefaultValue), Empty, DefaultValue)
' Open the key, exit if not found.
If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then
Exit Function
End If
' prepare a 1K receiving resBinary
length = 1024
ReDim resBinary(0 To length - 1) As Byte
' read the registry key
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
length)
' if resBinary was too small, try again
If retVal = ERROR_MORE_DATA Then
' enlarge the resBinary, and read the value again
ReDim resBinary(0 To length - 1) As Byte
retVal = RegQueryValueEx(handle, ValueName, 0, valueType, resBinary(0), _
length)
End If
' return a value corresponding to the value type
Select Case valueType
Case REG_DWORD
CopyMemory resLong, resBinary(0), 4
GetRegistryValue = resLong
Case REG_SZ, REG_EXPAND_SZ
' copy everything but the trailing null char
resString = Space$(length - 1)
CopyMemory ByVal resString, resBinary(0), length - 1
GetRegistryValue = resString
Case REG_BINARY
' resize the result resBinary
If length <> UBound(resBinary) + 1 Then
ReDim Preserve resBinary(0 To length - 1) As Byte
End If
GetRegistryValue = resBinary()
Case REG_MULTI_SZ
' copy everything but the 2 trailing null chars
resString = Space$(length - 2)
CopyMemory ByVal resString, resBinary(0), length - 2
GetRegistryValue = resString
Case Else
RegCloseKey handle
Err.Raise 1001, , "Unsupported value type"
End Select
' close the registry key
RegCloseKey handle
End Function
Function EnumRegistryKeys(ByVal hKey As Long, ByVal KeyName As String) As Collection
'Enumerate registry keys under a given key 'Returns a collection of strings
Dim handle As Long
Dim length As Long
Dim index As Long
Dim subkeyName As String
' initialize the result collection
Set EnumRegistryKeys = New Collection
' Open the key, exit if not found
If Len(KeyName) Then
If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) Then Exit Function
' in all case the subsequent functions use hKey
hKey = handle
End If
Do
' this is the max length for a key name
length = 260
subkeyName = Space$(length)
' get the N-th key, exit the loop if not found
If RegEnumKey(hKey, index, subkeyName, length) Then Exit Do
' add to the result collection
subkeyName = Left$(subkeyName, InStr(subkeyName, vbNullChar) - 1)
EnumRegistryKeys.Add subkeyName, subkeyName
' prepare to query for next key
index = index + 1
Loop
' Close the key, if it was actually opened
If handle Then RegCloseKey handle
End Function
Function CheckRegistryKey(ByVal hKey As Long, ByVal KeyName As String) As Boolean
' Return True if a Registry key exists
Dim handle As Long
' Try to open the key
If RegOpenKeyEx(hKey, KeyName, 0, KEY_READ, handle) = 0 Then
' The key exists
CheckRegistryKey = True
' Close it before exiting
RegCloseKey handle
End If
End Function
MODULO2
Option Explicit
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'@@@ Function Parent_Id_Prefix by Dessa '@@@
'@@@ Function LeerIdMontaje by Daniel Aue '@@@
'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
'Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
'Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
'Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Any) As Long
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const SYNCHRONIZE As Long = &H100000
Private Const STANDARD_RIGHTS_READ As Long = &H20000
Private Const KEY_READ As Long = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const ERROR_SUCCESS As Long = 0&
Private Const HKEY_LOCAL_MACHINE As Long = &H80000002
Public Function Parent_Id_Prefix(ByVal sLetra As String) As String
Dim strBinario As String: Dim DatosBinario() As Byte
If LeerIdMontaje("SYSTEM\MountedDevices", "\DosDevices\" & sLetra + ":", DatosBinario) = False Then Exit Function
strBinario = DatosBinario
'MsgBox DatosBinario, , "DatosBinario"
If Mid(strBinario, 1, 4) <> "\??\" Then Exit Function
strBinario = Replace(Mid(strBinario, 1, InStr(1, strBinario, "{") - 2), "#", "\")
'MsgBox strBinario, , "strBinario"
Parent_Id_Prefix = Mid(strBinario, InStrRev(strBinario, "\") + 1, InStrRev(strBinario, "&") - 1 - InStrRev(strBinario, "\"))
'MsgBox Parent_Id_Prefix, , "Parent_Id_Prefix"
End Function
Private Function LeerIdMontaje(ByVal strPath As String, ByVal strValueName As String, btValue() As Byte) As Boolean
Dim hKey As Long
Dim lngDataLen As Long
Dim lngResult As Long
Dim regType As Long
Dim btDataBuf() As Byte
If RegOpenKeyEx(HKEY_LOCAL_MACHINE, strPath, 0, KEY_READ, hKey) = ERROR_SUCCESS Then
If RegQueryValueEx(hKey, strValueName, 0, regType, ByVal 0&, lngDataLen) = ERROR_SUCCESS Then
ReDim btDataBuf(lngDataLen - 1) As Byte
If RegQueryValueEx(hKey, strValueName, 0, regType, btDataBuf(0), lngDataLen) = ERROR_SUCCESS Then
btValue = btDataBuf
'MsgBox btValue, , "btValue = DatosBinario"
LeerIdMontaje = True
End If
End If
RegCloseKey hKey
End If
End Function
|
|
|
|
|
En línea
|
Adrian Desanti
|
|
|
|
cobein
|
Lo saque de un modulo que uso que tiene mas cosas asi que si no estan todas las declaraciones... creo que si pero si falta algo lo pueden agregar. '---------------------------------------------------------------------------------------
' Module : mUSBSerial
' DateTime : 24/06/2008 07:54
' Author : Cobein
' Mail : cobein27@hotmail.com
' WebPage : http://www.advancevb.com.ar/
' Purpose : Read USB device srial.
' Usage : At your own risk
' Requirements: None
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
'
' History : 24/06/2008 First Cut....................................................
'---------------------------------------------------------------------------------------
Option Explicit
Private Const INVALID_HANDLE_VALUE As Long = (-1)
Private Const OPEN_EXISTING As Long = 3
Private Const GENERIC_READ As Long = &H80000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_SHARE_WRITE As Long = &H2
Private Const IOCTL_STORAGE_BASE As Long = &H2D
Private Const METHOD_BUFFERED As Long = 0
Private Const FILE_ANY_ACCESS As Long = 0
Private Const ERROR_NOERROR As Long = &H0
Private Const ERROR_INVALIDBUSTYPE As Long = &H2
Private Const ERROR_GENERICERROR As Long = &H4
Private Const DIGCF_PRESENT As Long = &H2
Private Const DIGCF_DEVICEINTERFACE As Long = &H10
Private Enum STORAGE_PROPERTY_ID
StorageDeviceProperty = 0
StorageAdapterProperty
End Enum
Private Enum STORAGE_QUERY_TYPE
PropertyStandardQuery = 0
PropertyExistsQuery
PropertyMaskQuery
PropertyQueryMaxDefined
End Enum
Public Enum STORAGE_BUS_TYPE
BusTypeUnknown = 0
BusTypeScsi
BusTypeAtapi
BusTypeAta
BusType1394
BusTypeSsa
BusTypeFibre
BusTypeUsb
BusTypeRAID
BusTypeMaxReserved = &H7F
End Enum
Private Type STORAGE_PROPERTY_QUERY
PropertyId As STORAGE_PROPERTY_ID
QueryType As STORAGE_QUERY_TYPE
AdditionalParameters(0) As Byte
End Type
Private Type STORAGE_DEVICE_NUMBER
dwDeviceType As Long
dwDeviceNumber As Long
dwPartitionNumber As Long
End Type
Private Type OVERLAPPED
Internal As Long
InternalHigh As Long
offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Type STORAGE_DEVICE_DESCRIPTOR
Version As Long
SIZE As Long
DeviceType As Byte
DeviceTypeModifier As Byte
RemovableMedia As Byte
CommandQueueing As Byte
VendorIdOffset As Long
ProductIdOffset As Long
ProductRevisionOffset As Long
SerialNumberOffset As Long
BusType As STORAGE_BUS_TYPE
RawPropertiesLength As Long
RawDeviceProperties(0) As Byte
End Type
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_DATA
cbSize As Long
InterfaceClassGuid As GUID
flags As Long
Reserved As Long
End Type
Private Type SP_DEVINFO_DATA
cbSize As Long
ClassGuid As GUID
DevInst As Long
Reserved As Long
End Type
Private Type SP_DEVICE_INTERFACE_DETAIL_DATA
cbSize As Long
strDevicePath As String * 260
End Type
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 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 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 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
Public Function GetUSBSerial(ByVal sDrive As String, ByRef sSerial As String) As Long
Dim sDriveFormated As String
Dim sData As String
On Local Error GoTo GetUSBSerial_Error
If Not GetDriveBusType(sDrive) = BusTypeUsb Then
GetUSBSerial = ERROR_INVALIDBUSTYPE
Exit Function
End If
sDriveFormated = "\\.\" & Left$(sDrive, 1) & ":"
sDrive = Left$(sDrive, 1) & ":"
sData = GetDriveDevicePathByDeviceNumber( _
GetDeviceNumber(sDriveFormated), GetDriveType(sDrive), sDrive)
sData = Split(sData, "#")(2)
sSerial = Split(sData, "&")(0)
GetUSBSerial = ERROR_NOERROR
Exit Function
GetUSBSerial_Error:
GetUSBSerial = ERROR_GENERICERROR
End Function
Private Function GetDriveDevicePathByDeviceNumber(ByVal lDevNumb As Long, ByVal lDriveType As Long, ByVal sDevice As String) As String
Dim tGUID As GUID
Dim hDevInfo As Long
Dim tSP_DEVICE_INTERFACE_DATA As SP_DEVICE_INTERFACE_DATA
Dim tSP_DEVICE_INTERFACE_DETAIL_DATA As SP_DEVICE_INTERFACE_DETAIL_DATA
Dim tSP_DEVINFO_DATA As SP_DEVINFO_DATA
With tGUID
.Data2 = &HB6BF: .Data3 = &H11D0&
.Data4(0) = &H94&: .Data4(1) = &HF2&
.Data4(2) = &H0&: .Data4(3) = &HA0&
.Data4(4) = &HC9&: .Data4(5) = &H1E&
.Data4(6) = &HFB&: .Data4(7) = &H8B&
Select Case lDriveType
Case 2
Dim sDosDev As String * 260
Call QueryDosDevice(Left$(sDevice, 1) & ":", sDosDev, 260)
If InStr(sDosDev, "\Floppy") Then
.Data1 = &H53F56311
Else
.Data1 = &H53F56307
End If
Case 3
.Data1 = &H53F56307
Case 5
.Data1 = &H53F56308
End Select
End With
hDevInfo = SetupDiGetClassDevs(VarPtr(tGUID), 0, 0, _
DIGCF_PRESENT Or DIGCF_DEVICEINTERFACE)
If hDevInfo = -1 Then Exit Function
tSP_DEVICE_INTERFACE_DATA.cbSize = Len(tSP_DEVICE_INTERFACE_DATA)
Dim lRet As Long
Dim lIndex As Long
Dim lSize As Long
Dim lReturn As Long
Do
lRet = SetupDiEnumDeviceInterfaces(hDevInfo, _
0, tGUID, lIndex, tSP_DEVICE_INTERFACE_DATA)
If lRet = 0 Then Exit Do
lSize = 0
Call SetupDiGetDeviceInterfaceDetail(hDevInfo, _
tSP_DEVICE_INTERFACE_DATA, ByVal 0&, 0, lSize, ByVal 0&)
If lSize <> 0 And lSize <= 1024 Then
tSP_DEVICE_INTERFACE_DETAIL_DATA.cbSize = 5
tSP_DEVINFO_DATA.cbSize = Len(tSP_DEVINFO_DATA)
If SetupDiGetDeviceInterfaceDetail(hDevInfo, _
tSP_DEVICE_INTERFACE_DATA, tSP_DEVICE_INTERFACE_DETAIL_DATA, _
ByVal lSize, lReturn, tSP_DEVINFO_DATA) Then
If lDevNumb = _
GetDeviceNumber(tSP_DEVICE_INTERFACE_DETAIL_DATA.strDevicePath) Then
Call SetupDiDestroyDeviceInfoList(hDevInfo)
GetDriveDevicePathByDeviceNumber = tSP_DEVICE_INTERFACE_DETAIL_DATA.strDevicePath
Exit Function
End If
End If
End If
lIndex = lIndex + 1
Loop
Call SetupDiDestroyDeviceInfoList(hDevInfo)
End Function
Private Function GetDeviceNumber(ByVal sDrive As String) As Long
Dim lDriveNum As Long
Dim hVolume As Long
Dim lRet As Long
Dim tSTORAGE_DEVICE_NUMBER As STORAGE_DEVICE_NUMBER
Dim lRetBytes As Long
lDriveNum = -1
hVolume = CreateFile(sDrive, 0, FILE_SHARE_READ Or FILE_SHARE_WRITE, _
ByVal 0&, OPEN_EXISTING, 0, 0)
If Not hVolume = INVALID_HANDLE_VALUE Then
If DeviceIoControl(hVolume, &H2D1080, ByVal 0&, ByVal 0&, _
tSTORAGE_DEVICE_NUMBER, Len(tSTORAGE_DEVICE_NUMBER), _
lRetBytes, ByVal 0&) Then
GetDeviceNumber = tSTORAGE_DEVICE_NUMBER.dwDeviceNumber
End If
Call CloseHandle(hVolume)
End If
End Function
Public Function GetDriveBusType(ByVal sDrive As String) As STORAGE_BUS_TYPE
Dim lRet As Long
Dim lDevice As Long
Dim tSTORAGE_DEVICE_DESCRIPTOR As STORAGE_DEVICE_DESCRIPTOR
Dim tOVERLAPPED As OVERLAPPED
Dim tSTORAGE_PROPERTY_QUERY As STORAGE_PROPERTY_QUERY
sDrive = Left(sDrive, 1) & ":"
lDevice = CreateFile("\\.\" & sDrive, 0, _
FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
If Not lDevice = INVALID_HANDLE_VALUE Then
With tSTORAGE_PROPERTY_QUERY
.PropertyId = StorageDeviceProperty
.QueryType = PropertyStandardQuery
End With
Call DeviceIoControl( _
lDevice, _
IOCTL_STORAGE_QUERY_PROPERTY, _
tSTORAGE_PROPERTY_QUERY, _
LenB(tSTORAGE_PROPERTY_QUERY), _
tSTORAGE_DEVICE_DESCRIPTOR, _
LenB(tSTORAGE_DEVICE_DESCRIPTOR), _
lRet, tOVERLAPPED)
GetDriveBusType = tSTORAGE_DEVICE_DESCRIPTOR.BusType
Call CloseHandle(lDevice)
End If
End Function
Private Function IOCTL_STORAGE_QUERY_PROPERTY() As Long
IOCTL_STORAGE_QUERY_PROPERTY = _
(IOCTL_STORAGE_BASE * 2 ^ 16) Or _
(FILE_ANY_ACCESS * 2 ^ 14) Or _
(&H500 * 2 ^ 2) Or _
(METHOD_BUFFERED)
End Function
|
|
|
|
« Última modificación: 12 Julio 2009, 06:33 am por cobein »
|
En línea
|
|
|
|
Dessa
Desconectado
Mensajes: 624
|
Gacias por tu tiempo cobein, voy a probar el modulo, en cuanto a WMI no encuentro mucha informacion al respecto, en que ocasiones puede estar no disponible ?
|
|
|
|
|
En línea
|
Adrian Desanti
|
|
|
|
seba123neo
|
Gacias por tu tiempo cobein, voy a probar el modulo, en cuanto a WMI no encuentro mucha informacion al respecto, en que ocasiones puede estar no disponible ?
si puede estar deshabilitado segun los permisos , si es administrador o no, sobre todo en vista...hay un codigo para saber si esta disponible. saludos.
|
|
|
|
|
En línea
|
|
|
|
tobu
Desconectado
Mensajes: 87
|
dios mio todo ésto para que reconozca la letra de unidad y del serial buffffff.pasate a net dios mio de mi alma.y no me digas que es net.
|
|
|
|
|
En línea
|
|
|
|
|
cobein
|
Dios mio de mi alma, 300 MB de un framework para no saber como se programa ni como se saca el serial de un USB drive.
Eso es a lo que yo llamo no tener idea de nada. "Usa NET que no tenes que aprender nada"
|
|
|
|
|
En línea
|
|
|
|
Karcrack
Desconectado
Mensajes: 2.416
Se siente observado ¬¬'
|
Dios mio de mi alma, 300 MB de un framework para no saber como se programa ni como se saca el serial de un USB drive.
Eso es a lo que yo llamo no tener idea de nada. "Usa NET que no tenes que aprender nada"
Eso, eso .NET abajo!!!... Odio las clases... no las del instituto, sino las de .NET  (Aunque las del instituto...   ) Lo mejor es saber programar con las APIs... eso del NET es un timo... 
|
|
|
|
|
En línea
|
|
|
|
BlackZeroX
Wiki
Desconectado
Mensajes: 3.158
I'Love...!¡.
|
"Usa NET que no tenes que aprender nada"
Por eso NO me gusta.¡!
|
|
|
|
|
En línea
|
The Dark Shadow is my passion.
|
|
|
Dessa
Desconectado
Mensajes: 624
|
dios mio todo ésto para que reconozca la letra de unidad y del serial buffffff.pasate a net dios mio de mi alma.y no me digas que es net.
Mejor ni opino, ya tengo dos "vacaciones del foro" este año. si puede estar deshabilitado segun los permisos , si es administrador o no, sobre todo en vista...hay un codigo para saber si esta disponible.
Gracias Seba, On Error Resume Next, luego cargar GetObject("winmgmts:") y si el error es igual a cero WMI está disponible, algo así ? S2
|
|
|
|
|
En línea
|
Adrian Desanti
|
|
|
|
seba123neo
|
mira este post habla justo de eso,ya sabia que estaba: Detectar si hay WMI (VB6)por ejemplo, la que yo hice de sacar la temperatura del disco duro con WMI, funciona bien si no tenes restricciones, pero lo he probado en otras maquinas que entras con una cuenta de usuario y no funciona el programa... saludos. |
|
|
|
|
En línea
|
|
|
|
|
 |
