Serial y Unidad de Pen Drive

[Dessa]

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:

Código [Seleccionar] Expandir



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

Código [Seleccionar] Expandir



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

Código [Seleccionar] Expandir



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




[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.

Código [Seleccionar] Expandir

'---------------------------------------------------------------------------------------
' 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


[Dessa]

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 ?

[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.

[tobu]

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.

[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"

[Karcrack]

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...

[BlackZeroX]

"Usa NET que no tenes que aprender nada"

Por eso NO me gusta.¡!

[Dessa]

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

[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.