Mensajes

Tambien fijate porque llamas a la variable "I" en el primer for.

Lo probé nuevamente, activé el UAC (a nivel predeterminado), luego reinicié windows y ejecuté el code sin ninguna respuesta (tampoco ningun error). Luego volví a desactivar el UAC y reiniciar windows, en este caso sí funcionó (con el UAC dasactivado)
Probé con Windows Seven RC 7100 con todas las actualizaciones al dia

S2   

En W7 como Adm. con el UAC predeterminado o alto iignora la instruccion, con el UAC desactivado si se clava el windows pero al reiniciar se inicia normalmente

S2 

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

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 ?

[APIs]

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




Ok, cobein, gracias por el aporte, pero cual seria la mejor solución para relacionar los seriales de los Pendrive con sos respectivas unidades ?

Por ejemplo usando APIs en XP se puede enumerar los seriales que se encuentran en HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Enum\USBSTOR y a travez del dato del valor ParentIdPrefix de cada serial se puede  relacionar con la unidad de cada pendrive conectado que se encuentran en HKEY_LOCAL_MACHINE\SYSTEM\MountedDevices (en el interior del dato Binario de cada unidad montada con Pendrive se encuentra tambien el valor ParentIdPrefix de cada serial, esto permitiria relacionar directamente los seriales con sus respectivas unidades). Pero no hay una manera mas directa ???

No encuentro una propiedad comun entre Win32_LogicalDisk y Win32_DiskDrive para relacionar directamente la letra de un pen con su serial

Retomé el tema hace unos dias y por fin pude encontrar la forma de relacionar directamente la unidad lógica de un Pendrive con con su serial (Win32_DiskDrive-PNPDeviceID), no es por intermedio de Win32_LogicalDisk sino por intermedio de Win32_LogicalDiskToPartition, esta clase me devuelve la letra Lógica (dependent) y el numero de index del disco al que corresponde (Antecedent), lo que queda es solo relacionar este numero de index con el tambien numero de index que devuelve Win32_DiskDrive (Win32_DiskDrive-index ) Y (Win32_DiskDrive-PNPDeviceID).

Paso el code para el que le pueda servir

Código [Seleccionar] Expandir



Private Function UsbSerial() As String

Dim disco1 As Object: Dim Objeto1 As Object ' Detecta seriales de Pendrive, MP3, Etc
Dim disco2 As Object: Dim Objeto2 As Object ' Autor = Dessa
Dim sDisco As String: Dim sLetra As String  ' http://foro.elhacker.net/programacion_vb-b50.0/

Set Objeto1 = GetObject("winmgmts:").ExecQuery("Select * from Win32_LogicalDiskToPartition")
Set Objeto2 = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf("Win32_DiskDrive")

For Each disco1 In Objeto1
     sLetra = Mid(disco1.dependent, InStr(1, disco1.dependent, "=") + 2, 2)
     sDisco = Mid(disco1.Antecedent, InStr(1, disco1.Antecedent, "#") + 1, InStrRev(disco1.Antecedent, ",") - InStr(1, disco1.Antecedent, "#"))
   For Each disco2 In Objeto2
     If disco2.InterfaceType = "USB" Then
       If disco2.Index = Val(Mid(sDisco, 1, Len(sDisco) - 1)) Then
         UsbSerial = UsbSerial + sLetra + " " & Mid(disco2.PNPDeviceID, InStrRev(disco2.PNPDeviceID, "\") + 1, InStrRev(disco2.PNPDeviceID, "&") - InStrRev(disco2.PNPDeviceID, "\") - 1) + vbNewLine
       End If
     End If
   Next
Next

End Function




PD: Funcinó en XP-SP3 y W7

S2

ademas segui leyendo y ya entendi que hacen HWND_BROADCAST (el mensaje llega a todas las ventanas) y WM_SETTINGCHANGE (sirve para que las ventanas tomen los cambios)

Exacto, S2

Probá si te sirve este code.

Código [Seleccionar] Expandir



Option Explicit

Private Sub Form_Load()
Me.AutoRedraw = True: Me.Height = 6045: Me.Width = 4300
LoadControl
End Sub

Sub LoadControl()
 If WMI_disponible() Then
   'Me.Print "TU SISTEMA TIENE WMI", vbOKOnly + vbInformation, "WMI"
   getWMI_Info
 Else
   Me.Print "TU SISTEMA NO TIENE WMI", vbOKOnly + vbExclamation, "WMI"
 End If
End Sub

Public Function WMI_disponible() As Boolean
Dim WMI As Object
On Error Resume Next
Set WMI = GetObject("winmgmts:")
WMI_disponible = (Err.Number = 0)
End Function

Private Sub getWMI_Info()

Dim oAdapters As Object
Dim oAdapter As Object
On Error GoTo Fehler_WMI

Me.Print "----------------------------------------------------------------------------------------------"

Set oAdapters = GetObject("winmgmts:").ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")

Dim ctlip1 As String: Dim ctlip2 As String

For Each oAdapter In oAdapters
 With oAdapter
   'Me.Cls '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   If Join(.IPAddress) <> ctlip1 Then
       Me.Print "NOMBRE:" & vbTab & vbTab & vbTab & Environ$("computername")
       Me.Print "DIRECCION IP:" & vbTab & vbTab & vbTab & Join(.IPAddress)
       Me.Print "MASCARA DE SUBRED:" & vbTab & Join(.IPSubnet)
       'If Not IsNull(.DefaultIPGateway) Then
           Me.Print "PUERTA DE ENLACE:" & vbTab & vbTab & Join(.DefaultIPGateway)
       'End If
       Me.Print "DIRECCION MAC:" & vbTab & vbTab & .MACAddress
       Me.Print "DNS:" & vbTab & vbTab & vbTab & vbTab & .DNSHostName
       'If .WINSPrimaryServer <> "" Then
           Me.Print "WINS 1:" & vbTab & vbTab & vbTab & .WINSPrimaryServer
       'End If
       'If .WINSSecondaryServer <> "" Then
           Me.Print "WINS 2:" & vbTab & vbTab & vbTab & .WINSSecondaryServer
       'End If
       Me.Print ":---------------------------------------------------------------------------------------------"
       ctlip1 = Join(.IPAddress)
   End If
 End With
Next

On Error GoTo 0
Exit Sub

Fehler_WMI:
MsgBox "Error: " & Err.Number & vbTab & Err.Description, vbCritical
Resume Next
End Sub



S2