como puedo que vb6 me resconosca una usb espesifica

[01ebb]

hola a todos me gustaria que me muestren un ejemplo que cuando uno meta una usb me la reconosca y poderle meter archivos automaticamente sin que el usuario sede cuenta pero me gustaria que a otros no cuando metan la usb espero que me entiendan este trabalenguas


muchas pero muchas gracias


por sierto la pagina quedo super

[richardvp2003]

Obviamenet por su numero de serie del USB....

Private Declare Function GetVolumeInformatio n Lib "Kernel32" Alias "GetVolumeInformatio nA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumbe r As Long, lpMaximumComponentL ength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuf fer As String, ByVal nFileSystemNameSize As Long) As Long

Private Function DriveSerial(ByVal sDrv As String) As Long
    Dim RetVal As Long
    Dim str As String * MAX_FILENAME_LEN
    Dim str2 As String * MAX_FILENAME_LEN
    Dim a As Long
    Dim b As Long
    Call GetVolumeInformatio n(sDrv & ":\", str, MAX_FILENAME_LEN, RetVal, a, b, str2, MAX_FILENAME_LEN)
    DriveSerial = RetVal
End Function

y ahy sacas el numero de seri de la unidad... lo k me falta es bloquear el usb si no es el mismo numero de serie alguna idea ?

mi correo es prohibidoslosmailse nposts:-com 

[kaco_rcm]

una duda con este codigo como puedes dejar el numero de serie dentro de un textbox?


saludos

[>> s E t H <<]

text1=driveserial("D")

tenes que aprender a usar funciones me parece..

[kaco_rcm]

mmmmm  deacuerdo en eso tienes razon pero creo que jamas esta demas aprender algo aunque mui insignificante paresca..
creo que si hases la prueba no te correra... lo primero que hise es lo que tu indicas , pero el prog me alego por los parametros y bla bla bla, ok ojala resulte seguire probando xau

[700esoj]

jajaja me parece que la const MAX_FILENAME_LEN no esta? alguien Sabe cual es esa const? mientras tanto puse un numero como 1000

algo asi

Código:

Const MAX_FILENAME_LEN = 350


Private Function DriveSerial(ByVal sDrv As String) As Long
    Dim RetVal As Long
    Dim str As String * MAX_FILENAME_LEN
    Dim str2 As String * MAX_FILENAME_LEN
    Dim a As Long
    Dim b As Long
    Call GetVolumeInformation(sDrv & ":\", str, MAX_FILENAME_LEN, RetVal, a, b, str2, MAX_FILENAME_LEN)
    DriveSerial = RetVal
End Function

Private Sub Command1_Click()
Text1.Text = DriveSerial("D")
End Sub


'el resultado que me da es -389224386

[>> s E t H <<]

les dejo este pedazo de una tool mia (se llama stfw y esta en el foro de source)

Código:

'######################################################################################################################################################################################################################################################################################################################################################################
'para averiguar el label de los discos
Private Declare Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long)
'para saber que tipo de disco es
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

'######################################################################################################################################################################################################################################################################################################################################################################
Private Function AveriguarLabel(Letra) As String
On Error Resume Next
  Dim cad1 As String * 256
  Dim cad2 As String * 256
  Dim numSerie As Long
  Dim longitud As Long
  Dim flag As Long
  Unidad = Letra
  Call GetVolumeInformation(Unidad, cad1, 256, numSerie, longitud, flag, cad2, 256)
  AveriguarLabel = "Label de la unidad " & Unidad & " = " & NoEncontrado(cad1)
End Function


Private Sub CmbLetraUnidad_Click()
LblLabelUnidad.Caption = AveriguarLabel(CmbLetraUnidad.Text)
Call AveriguarEspacio(CmbLetraUnidad.Text)
LblNumeroDeSerieDeDisco = "Número de serie del disco: " & NumeroDeSerieDeDisco(CmbLetraUnidad.Text)
Dim DriveTip As Long
DriveTip = GetDriveType(CmbLetraUnidad.Text)
    Select Case DriveTip
        Case 2
            LblTipoDeDisco = "Tipo de disco: " & "Removible"
        Case 3
            LblTipoDeDisco = "Tipo de disco: " & "Disco duro"
        Case Is = 4
            LblTipoDeDisco = "Tipo de disco: " & "Remoto"
        Case Is = 5
            LblTipoDeDisco = "Tipo de disco: " & "Cd-Rom"
        Case Is = 6
            LblTipoDeDisco = "Tipo de disco: " & "Ram"
        Case Else
            LblTipoDeDisco = "Tipo de disco: " & "Desconocido"
    End Select


End Sub

'con esto averiguamos el numero de serie:
Private Function NumeroDeSerieDeDisco(Letra)
    Dim cad1 As String * 256
    Dim cad2 As String * 256
    Dim numSerie As Long
    Dim longitud As Long
    Dim flag As Long
    Unidad = Letra
    Call GetVolumeInformation(Unidad, cad1, 256, numSerie, longitud, flag, cad2, 256)
    NumeroDeSerieDeDisco = numSerie
    'ponemos el tipo de sistema de archivos
    LblSistemaDeArchivos = "Sistema de archivos: " & NoEncontrado(Trim(cad2))
End Function
'######################################################################################################################################################################################################################################################################################################################################################################

creo que lo unic que falta es meter los controles, pero funciona bien

[kaco_rcm]

  si  saqe el code de forma parecida y con comparacion que reconose el cambio de usb y bla, bla bla, llegandomañana ami casa posteo
el code  que modifique conla comparacion . saludos

[kaco_rcm]

disculpen se mealargo la yegada a mi casa por una  femina , yegandolo posteo disculpen por la demora, pero creo que
de igual forma esta demas, con el code de seth, que se ve buenisimo aun nolo pruebo pero por lo que veo tiene acceso a mas dispositivos fisicos.
saludos y mañana yegando posteo.
disculpen la tardanza

[>> s E t H <<]

si lo probas asi no va  a andar, faltan muchas cosas.. es solo para solucionar la duda de arriba... si queres verlo funcionando bajate el programa que nombre antes

[kaco_rcm]

ok aqui posteo el code que les mencione anteriormente, mas avajo explico un poco pero creo que mas claro echarle agua

Private Declare Function GetVolumeInformatio n& Lib "kernel32" Alias "GetVolumeInformatio nA" (ByVal lpRootPathName As String, ByVal pVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumbe r As Long, lpMaximumComponentL ength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuf fer As String, ByVal nFileSystemNameSize As Long)

Private Sub Command1_Click()
 Dim cad1 As String * 256
    Dim cad2 As String * 256
    Dim numSerie As Long
    Dim longitud As Long
    Dim flag As Long
    unidad = "d:\"
    Call GetVolumeInformatio n(unidad, cad1, 256, numSerie, longitud, flag, cad2, 256)
    MsgBox "Numero de Serie de la unidad " & unidad & " = " & numSerie
    Text1.Text = numSerie
End Sub

Private Sub Command2_Click()
Open "c:\serial.txt" For Output As #1
        Print #1, Text1
        Close
End Sub

Private Sub Command3_Click()
If Val(Text1.Text) = Val(RichTextBox1.Text) Then
MsgBox ("igual")
Else
MsgBox ("no igual")
End If
End Sub

Private Sub Form_Load()
RichTextBox1.FileNa me = "c:\serial.txt"
End Sub

en este caso estoy viendo en la unidad c sirve tanto para pendriver como  discos duros, la pendriver que utilice aparece en d:
ahi ves tu en que pocicion te aparece o puedes comparar todas las unidades
en este caso cree un archivo en la unidad c: con cuidado este archivo deves crearlo antes de hacer correr el programa
osino te dara error cree tres botones un par de cajas de texto , y el code te dice lo demas ,
bueno lo hice solo por curiocidad , asi que no esta mui decente el code , pero lo puedes automatizar con un timer o simplemente al cargar el form.
saludos , espoero que sirva de algo,