Mensajes

Hola a todos tengo una pregunta estoy buscando la forma de formatear un pendrive con VB 6 sin usar SHFormatDrive que lo unico que hace es abrir la ventana de Windows "Dar Formato"... a ver si me explico se puede formatear un pendrive por codigo sin abrir la ventana de Windows "Dar Formato"

Alguna pista????
Gracias por su ayuda

Hola a todos despues de una larga busqueda no puedo hallar un codigo para obtener el product id y el vendor id de un pen drive
lo que necesito es un codigo que me muestre lo siguiente:
Unidad: F: Product ID: 1A34 Vendor ID: 6H78
Unidad: G: Product ID: 245J Vendor ID: 7E8H
etc
donde unidad son los pen drives detectados

Alguien me puede ayudar 
Se lo agradecere muchisimo
Un saludo

Hola "invisible_hack" los codigos del post ya los tengo los subi yo y seba los ordeno ese codigo obtiene el esn pero yo ahora necesito obtener el product id y el vendor id de un pen drive con VB 6

nuevamente si me podes ayudar gracias

Hola a todos alguien me puede ayudar a obtener el Product ID y el Vendor ID de un Pen Drive con VB 6
muchas gracias
un saludo

fijate en el foro Detectar Product ID y Vendor ID de un Pen Drive que subi un codigo que hace lo que vos pedis.... si insertas un pen drive te tira los datos letra de unidad numero de volumen y ESN (numero de serie del fabricante) que es el que vos buscas ... el problema es que si insertas dos pen juntos los datos salen cambiados
si sabes  como solucionarlo te lo agradecere
un saludo
espero que el codigo te sea util

el codigo que arme costa de un modulo y dos frm

en el frm va esto

Código (vb) [Seleccionar] Expandir

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

Código (vb) [Seleccionar] Expandir

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

Código (vb) [Seleccionar] Expandir

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

ya lo subo un saludo

Hola a todos alguien tiene un codigo para detectar el  Product ID y Vendor ID de un Pen Drive con VB 6 por que lo que encontre en la web no me funca o no lo entiendo (soy bastante nuevo en programacion)
muchas gracias
un saludo

Hola a todos necesito un codigo sencillo para descomprimir un archivo .cab (el cual ya compacte con codigo VB)  pero no encuentro la forma de extraerlo
si me pueden ayudar muchas gracias           

Hola perdon por molestar soy nuevo en el foro.... necesito obtener el ESN(numero de serie) de un pen drive el numero q necesito es el que graba el fabricante no el numero de volumen que cambia al formatear... si alguien me puede ayudar
muchas gracias