el codigo que arme costa de un modulo y dos frm
en el frm va esto
Option Explicit
Dim matriz_Volume(1 To 26, 1 To 26) As String
Dim matriz_ESN(1 To 26) As String
Private Sub cmdExtraer_Click()
If lst1.ListIndex > -1 Then
EjectDevice (lst1.List(lst1.ListIndex))
lst1.RemoveItem (lst1.ListIndex)
lst1.Refresh
Else
MsgBox "No hay dispositivos USB instalados"
End If
End Sub
Private Sub Form_Load()
'LocalDrives
'HookForm Me.hwnd
'Dame_Unidad_USB
'Numero_de_Serie
'Mostrar
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnHookForm Me.hwnd
End Sub
Private Sub cmdDetectar_Click()
Call Dame_Unidad_USB
Call Numero_de_Serie
Call Mostrar
End Sub
Public Sub Numero_de_Serie()
Dim Disco As Object
Dim cadena As String
Dim largo As Integer
Dim contador As Integer
Dim i As Integer
Dim posicion As Integer
Dim resultado As String
Dim largo_Res As Integer
Dim contador2 As Integer
Dim j As Integer
Dim posicion2 As Integer
Dim ESN As String
Dim k As Integer
k = 1
With GetObject("WinMgmts:")
For Each Disco In .InstancesOf("Win32_DiskDrive") ' 3 objetos 2 usb + ide
If Disco.InterfaceType = "USB" Then ' detecto si son usb
cadena = Disco.PNPDeviceID 'tiene embebido el ESN
largo = Len(cadena)
contador = 0
For i = largo To 1 Step -1
posicion = InStr(i, cadena, "\")
contador = contador + 1
If posicion > 0 Then
resultado = Right(cadena, contador - 1)
Exit For
End If
Next
largo_Res = Len(resultado)
contador2 = 0
For j = largo_Res To 1 Step -1
posicion2 = InStr(j, resultado, "&")
contador2 = contador2 + 1
If posicion2 > 0 Then
ESN = Left(resultado, largo_Res - contador2) 'resultado2 = Left(resultado, largo_Res - contador2)
matriz_ESN(k) = ESN
k = k + 1
'lst1.AddItem ESN
Exit For
End If
Next
End If ' cierra el primer if el q detecta usb
Next ' cierra el for q recorre los objetos
End With
End Sub
Public Sub Dame_Unidad_USB()
Dim NumDisco As Integer
Dim StrDisco As String
Dim ret As Long
Dim letra_Unidad As String
Dim numero_Volume As Long
Dim bandera As Boolean
'Dim matriz_Volume(0 To 25, 0 To 25) As String
Dim i As Integer
lst1.Clear
bandera = False
i = 1
For NumDisco = 0 To 25
StrDisco = Chr(NumDisco + 65) & ":\" 'convierte a char c/numero del bucle esta es la letra a verificar
If NumDisco = 0 Then
ret = GetDriveType(StrDisco)
ElseIf NumDisco > 0 And GetDriveType(StrDisco) = 2 Then ' si pasa x este if se detecto un USB
ret = 7
letra_Unidad = StrDisco
numero_Volume = GetVolumeNumber(StrDisco) 'obtengo el numero de volumen 'lESNUnidad = GetVolumeNumber(StrDisco)
matriz_Volume(i, 1) = letra_Unidad
matriz_Volume(i, 2) = Hex(numero_Volume)
i = i + 1
'MsgBox matriz_Volume(1, 1) & matriz_Volume(1, 2)
'lst1.AddItem matriz_Volume(i, 1) & matriz_Volume(i, 2) & matriz_Volume(i, 3)
'lst1.AddItem letra_Unidad & " " & Hex(numero_Volume)
bandera = True
ElseIf NumDisco > 0 And GetDriveType(StrDisco) <> 2 Then
ret = GetDriveType(StrDisco)
End If
Next
If bandera = False Then
MsgBox "No hay dispositivos USB instalados"
End If
End Sub
Public Sub Mostrar()
Dim i As Integer
For i = 1 To 26
lst1.AddItem matriz_Volume(i, 1) & " " & matriz_ESN(i) & " " & matriz_Volume(i, 2)
Next
End Sub
Function GetVolumeNumber(strDrive As String) As Long ' obtengo el numero de volumen de la letra q le paso
Dim SerialNum As Long
Dim res As Long
Dim Temp1 As String
Dim Temp2 As String
Temp1 = String$(255, Chr$(0))
Temp2 = String$(255, Chr$(0))
res = GetVolumeInformation(strDrive, Temp1, _
Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
GetVolumeNumber = SerialNum
End Function
en el modulo Module 1 va este codigo
Option Explicit
Declare Function GetVolumeInformation Lib "kernel32.dll" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long
'Declare Function GetSerialNumber Lib "kernel32.dll" (ByVal sDrive As String) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetLogicalDrives Lib "kernel32" () As Long
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Type DEV_BROADCAST_HDR
dbch_size As Long
dbch_devicetype As Long
dbch_reserved As Long
End Type
Public Const GWL_WNDPROC = -4
Public Const WM_DEVICECHANGE As Long = 537 'Cambios en un dispositivo
Public Const DBT_DEVICEARRIVAL As Long = 32768 'Cuando se conecta uno nuevo
Public Const DBT_DEVICEREMOVECOMPLETE As Long = 32772 'Cuando se desconecta uno
Public Const DBT_DEVTYP_VOLUME As Integer = 2 'Logical volume, cualquier unidad de almacenamiento nueva.
Dim PrevProc As Long
Dim lArray() As String
Public Sub HookForm(hwnd As Long)
PrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub UnHookForm(hwnd As Long)
SetWindowLong hwnd, GWL_WNDPROC, PrevProc
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
If uMsg = WM_DEVICECHANGE Then
If wParam = DBT_DEVICEARRIVAL Then
Dim dev As DEV_BROADCAST_HDR
CopyMemory dev, ByVal lParam, 12
If dev.dbch_devicetype = DBT_DEVTYP_VOLUME Then
'Mostramos la letra de la ultima unidad de almacenamiento conectada
'MsgBox USBConected
Form1.lst1.Clear
Call Detectar
End If
ElseIf wParam = DBT_DEVICEREMOVECOMPLETE Then
'Si se desconecta alguno volvemos ha hacer toda la lista.
'LocalDrives
Call Remover
End If
End If
End Function
Public Function USBConected() As String
Dim hVolume As Long, i As Integer, b As Integer, find As Boolean
hVolume = GetLogicalDrives()
For i = 0 To 25
If (hVolume And 2 ^ i) <> 0 Then
For b = 0 To UBound(lArray)
If lArray(b) = Chr(i + 65) Then find = True: Exit For
Next b
If find = False Then
ReDim Preserve lArray(UBound(lArray) + 1)
lArray(UBound(lArray)) = Chr(i + 65)
USBConected = Chr(i + 65) & ":"
Exit Function
End If
End If
find = False
Next i
End Function
Public Sub LocalDrives()
Dim hVolume As Long, count As Integer, i As Integer
Erase lArray
count = 0
hVolume = GetLogicalDrives()
For i = 0 To 25
If (hVolume And 2 ^ i) <> 0 Then
ReDim Preserve lArray(count)
lArray(count) = Chr(i + 65)
count = count + 1
End If
Next i
End Sub
Public Sub Remover()
If Form1.lst1.ListIndex > -1 Then
EjectDevice (Form1.lst1.List(Form1.lst1.ListIndex))
Form1.lst1.RemoveItem (Form1.lst1.ListIndex)
Form1.lst1.Refresh
Else
MsgBox "No hay dispositivos USB instalados"
End If
End Sub
Public Sub Detectar()
Dim NumDisco As Integer
Dim StrDisco As String
Dim ret As Long
Dim lESNUnidad As Long
Dim bandera As Boolean
bandera = False
For NumDisco = 0 To 25
StrDisco = Chr(NumDisco + 65) & ":\" ' combierte a char c/numero del bucle
If NumDisco = 0 Then
ret = GetDriveType(StrDisco)
ElseIf NumDisco > 0 And GetDriveType(StrDisco) = 2 Then ' si pasa x este if se detecto un USB
ret = 7
lESNUnidad = GetVolumeNumber(StrDisco)
Form1.lst1.AddItem StrDisco & " " & Hex(lESNUnidad)
bandera = True
ElseIf NumDisco > 0 And GetDriveType(StrDisco) <> 2 Then
ret = GetDriveType(StrDisco)
End If
Next
Form1.lst1.AddItem "--------------------------------------------------"
If bandera = False Then
Form1.lst1.Clear
MsgBox "No hay ningun dispositivo USB detectado"
End If
End Sub
Function GetVolumeNumber(strDrive As String) As Long
Dim SerialNum As Long
Dim res As Long
Dim Temp1 As String
Dim Temp2 As String
Temp1 = String$(255, Chr$(0))
Temp2 = String$(255, Chr$(0))
res = GetVolumeInformation(strDrive, Temp1, Len(Temp1), SerialNum, 0, 0, Temp2, Len(Temp2))
GetVolumeNumber = SerialNum
End Function
en el otro modulo llamado modDevEject va este codigo
Option Explicit
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
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 HKEY_LOCAL_MACHINE As Long = &H80000002
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 Declare Function CM_Request_Device_EjectA Lib "setupapi.dll" (ByVal hDevice As Long, lVetoType As Long, lpVetoName As Any, ByVal cbVetoName As Long, ByVal dwFlags As Long) As Long
Private Declare Function CM_Locate_DevNodeA Lib "setupapi.dll" (hDevice As Long, lpDeviceName As Any, ByVal dwFlags As Long) As Long
Private Declare Function CM_Get_Device_IDA Lib "setupapi.dll" (ByVal hDevice As Long, ByVal lpIDBuffer As Long, ByVal cbIDBuffer As Long, ByVal dwFlags As Long) As Long
Private Declare Function CM_Get_Device_ID_Size Lib "setupapi.dll" (ByRef lSize As Long, ByVal hDevice As Long, ByVal dwFlags As Long) As Long
Private Declare Function CM_Get_Parent Lib "setupapi.dll" (hParentDevice As Long, ByVal hDevice As Long, ByVal dwFlags As Long) As Long
Private Declare Function CM_Get_Child Lib "setupapi.dll" (hChildDevice As Long, ByVal hDevice As Long, ByVal dwFlags As Long) As Long
Private Declare Function CM_Get_Sibling Lib "setupapi.dll" (hSiblingDevice As Long, ByVal hDevice As Long, ByVal dwFlags As Long) As Long
Private Declare Function CM_Get_DevNode_Status Lib "setupapi.dll" (lStatus As Long, lProblem As Long, ByVal hDevice As Long, ByVal dwFlags As Long) As Long
Private Const DN_REMOVABLE As Long = &H4000
Private Const CR_SUCCESS As Long = 0
Private Const REG_PATH_MOUNT As String = "SYSTEM\MountedDevices"
Private Const REG_VALUE_DOSDEV As String = "\DosDevices\"
Public Function EjectDevice(ByVal DriveLetter As String) As Boolean
Dim strDeviceInstance As String
Dim btRegData() As Byte
Dim hDevice As Long
Dim lngStatus As Long
Dim lngProblem As Long
DriveLetter = UCase$(Left$(DriveLetter, 1)) & ":"
If Not HKLMRegBinaryRead(REG_PATH_MOUNT, REG_VALUE_DOSDEV & DriveLetter, btRegData) Then
Exit Function
End If
strDeviceInstance = btRegData
If Not Left$(strDeviceInstance, 4) = "\??\" Then Exit Function
strDeviceInstance = Mid$(strDeviceInstance, 5, InStr(1, strDeviceInstance, "{") - 6)
strDeviceInstance = Replace$(strDeviceInstance, "#", "\")
If CR_SUCCESS <> CM_Locate_DevNodeA(hDevice, ByVal strDeviceInstance, 0) Then
Exit Function
End If
If CR_SUCCESS <> CM_Get_DevNode_Status(lngStatus, lngProblem, hDevice, 0) Then
Exit Function
End If
Do While Not (lngStatus And DN_REMOVABLE) > 0
If CR_SUCCESS <> CM_Get_Parent(hDevice, hDevice, 0) Then Exit Do
If CR_SUCCESS <> CM_Get_DevNode_Status(lngStatus, lngProblem, hDevice, 0) Then Exit Do
Loop
If (lngStatus And DN_REMOVABLE) > 0 Then
EjectDevice = CR_SUCCESS = CM_Request_Device_EjectA(hDevice, 0, ByVal Space$(255), 255, 0)
End If
End Function
Private Function HandleToDeviceID(hDevice As Long) As String
Dim strDeviceID As String
Dim cDeviceID As Long
If CM_Get_Device_ID_Size(cDeviceID, hDevice, 0) = 0 Then
strDeviceID = Space(cDeviceID)
If CM_Get_Device_IDA(hDevice, StrPtr(strDeviceID), cDeviceID, 0) > 0 Then
strDeviceID = StrConv(strDeviceID, vbUnicode)
strDeviceID = Left(strDeviceID, cDeviceID)
Else
strDeviceID = ""
End If
End If
HandleToDeviceID = strDeviceID
End Function
Private Function HKLMRegBinaryRead(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
HKLMRegBinaryRead = True
End If
End If
RegCloseKey hKey
End If
End Function
el programa costa de un listbox y dos botones detectar y extraer me muestra la letra de la unidad,el numero de volumen,y el ESN (numero de serie electronico)
el problema es que si inserto 2 Pen Drive la letra de la unidad no coincide con los numeros de serie y de volumen
es decir me muestra F: numero volumen 33 ESN 44
pero 33 y 44 no son los numeros de la unidad F sino de la unidad G:
Alguna idea de como lo puedo solucionar ??????????????
muchas gracias un saludo