Discussion :

[clemclem2121]

Bonjour je suis à la recherche d'un code VBA efficace qui sur l'ouverture du formulaire d'entrée sur l'application vérifie :
Si une clé USB précise (n° série) est connecté sur l'ordinateur. SI la clé est présente alors ouverture du menu si non message d'erreur et fermeture automatique de l'application.

[madefemere]

Bonjour,

Cette discussion devrait t'apporter une solution ou des pistes.

De même une recherche sur le site avec "Vérifier présence clé USB" devrait te donner des pistes.

Bonne continuation

[clemclem2121]

Merci pour ta réponde j'ai déja consulté cette discution meme commenter pour avoir plus de details et pas de réponse

[madefemere]

Bonjour,

Je ne comprends pas, car je viens de tester et apparemment ça marche sans aucune difficulté (c'est la première fois que j'utilise ce genre de trucs, je te préviens).
Si t'as pas encore trouver de solutions peux-tu préciser.
@+

[clemclem2121]

Et bien j'ai fait pareil. J'ai copié le code sur le chargement d'un formulaire de bienvenu. Et cela ne marche pas j'ai beau changer de numéro de série, access m'affiche la boite de dialogue suivante

[Tofalu]

Le projet VBA compile bien ? Avez vous vérifié les événements du formulaire en question dans la fenêtre propriétés ?

[madefemere]

Bonsoir,

Pour utiliser les MSO, il faut cocher la référence "Microsoft Scripting Runtime".

Cordialement

[clemclem2121]

Ha merci pour ce petit oubli qui change beaucoup de chose ça fonctionne effectivement avec des numéros de série de type 03222334 mais hélas quand il y a des lettres dans le numéro de série ( 7F00BAA1) cela ne marche plus il m'indique une erreur.

[Tofalu]

Faites un effort : sérieusement, comment voulez-vous que quelqu'un vous aide alors que vous ne précisez en rien vos demandes ? Quel est le message d'erreur, qu'avez vous modifiez dans le code, etc ? Concernant la référence de MSO, il en est fait question à de nombreuses reprises dans la FAQ et les tutoriels qui y sont dédiés.

La restriction d'une application est la dernière chose à mettre en oeuvre dans une application déjà bien aboutie et maîtrisée de bout en bout (gestion d'erreur, gestion des références, ...) Quand un simple changement de type de variable lève une erreur insurmontable, il y a de quoi se poser des questions non

[clemclem2121]

Désolé, je débute sur VBA j'ai créé une application simple et je voulais plus d'info et essayer de voir comment la diffuser.
Bref j'ai recopier le code trouver sur http://www.developpez.net/forums/d59...untime-access/

Dans un premier temps :
Je n'ai pas changer le numéro de série que l'auteur du code avais mis pour voir si j’insérais un clé USB "fausse" cela me mettrai le code d'erreur prévu. Effectivement cela marche même si le drive n'est pas le bon F: alors que je suis sur mon PC sur G: avec ma clé.

Deux choses me pose problème
J'ai alors changer plusieurs choses :

Premièrement j'ai mis le déclenchement du code sur un clic de bouton -----> ça continu à fonctionner.
Ensuite j'ai trouver grâce à un soft le numéro de série de ma clé (20044526920F55C0359E) j'ai donc changer la valeur de NumSerie de Long à String (car c'est une chaîne de caractères).
Pour finir j'ai ajouté, le code si la clé détectée est la bonne, mais c'est la que ça coince puisqu'il me quitte automatiquement l’application.

Je met en copie ma version du code.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
 
Option Compare Database
 
Public fso As FileSystemObject
Public Drive As Drive
Public NumSerieUSB As String
Public DongleOK As Boolean
 
 
 
Private Sub Commande0_Click()
'************ Tester si la clé est presente au démarrage ************
 
    NumSerieUSB = "20044526920F55C0359E"   ' Numéro de série de la clé USB
    DongleOK = False        ' Met le Dongle absent
    Scan_Dongle             ' Va à la procédure Scan du dongle
    If DongleOK = False Then
    DoCmd.Quit
    Exit Sub
    End If
End Sub
 
 
'************ TESTER si (USB se connecte) ************
'************ si oui, ne traiter que les périphériques de stockage de type USB ************
Private Sub SysInfo1_DeviceArrival(ByVal devicetype As Long, ByVal deviceid As Long, ByVal devicename As String, ByVal devicedata As Long)
    ' Ne traiter que les unités de stockage de type data0
    If devicetype <> 2 Or devicedata <> 0 Then Exit Sub
 
    ' Scan de la presence du dongle
    Scan_Dongle
 
    If DongleOK = True Then
    DoCmd.OpenForm ([Menu de Prépa'Sport PRO])    'Si la clé est la bonne il faut ouvrir ce formualaire
    End If
End Sub
 
 
'************ TESTER si (USB se déconnecte) ************
'************ si oui, ne traiter que les périphériques de stockage de type USB ************
Private Sub SysInfo1_DeviceRemoveComplete(ByVal devicetype As Long, ByVal deviceid As Long, ByVal devicename As String, ByVal devicedata As Long)
 
    ' Ne traiter que les unités de stockage de type data0
    If devicetype <> 2 Or devicedata <> 0 Then
        Exit Sub
    End If
 
    'Si le dongle est déconnecté fin du prog
    If Log(deviceid) / Log(2) + 65 = DongleLettre Then
        Unload Me  'Code pour quitter le programme
    End If
End Sub
 
'************ Tester si la clé USB est présente
Sub Scan_Dongle()
    On Error GoTo Err
    If DongleOK = True Then
    DoCmd.OpenForm ([Menu de Prépa'Sport PRO])
        Exit Sub    ' si Dongle déja présent pas de scan
    End If
 
    ' Retrouver le dongle et son numéro de serie
    Set fso = New FileSystemObject
    For Each Drive In fso.Drives
        If Drive.IsReady = True And Drive.DriveLetter <> "c:" And Drive.DriveLetter <> "d:" Then
 
            If NumSerieUSB = fso.Drives(Drive + "\").SerialNumber Then
                DongleOK = True                     ' dongle present
                DongleLettre = Asc(Left$(Drive, 1))   ' memorise la lettre du dongle
                Set fso = Nothing
                Exit Sub
            End If
        Else
            Série = fso.Drives(Drive + "\").SerialNumber
            Msg = MsgBox("Il y a un problème avec le lecteur " & Drive & vbCrLf & "Erreur: " & Err.DESCRIPTION, vbInformation + vbOKOnly, "Erreur disque")
        End If
    Next
Err:
    If Err.Number = 71 Then
        Msg = MsgBox("Il y a un problème avec le lecteur " & Drive & vbCrLf & "Erreur: " & Err.DESCRIPTION, vbInformation + vbOKOnly, "Erreur disque")
    End If
End Sub

[madefemere]

Bonjour,

Si tu arrives à ce niveau :

Pour finir j'ai ajouté, le code si la clé détectée est la bonne, mais c'est la que ça coince puisqu'il me quitte automatiquement l’application.

t'es pas loin, il faut vérifier ce que contient la vérification au niveau de la ligne 67 :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If NumSerieUSB = fso.Drives(Drive + "\").SerialNumber Then

Donc il faut voir les 2 valeurs AVANT la vérification avec un Debug.print ou un MsgBox par :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Debug.print fso.Drives(Drive + "\").SerialNumber
Debug.print NumSerieUSB

Bonne continuation

[clemclem2121]

Lorsque j'exécute les deux debug
Debug.Print fso.Drives(Drive + "\").SerialNumber ------> Erreur 424 Objet Manquant
Debug.Print NumSerieUSB ---------> rien ne s'affiche !

[Tofalu]

Ce serait plutôt :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
If NumSerieUSB = Drive SerialNumber Then
                DongleOK = True                     ' dongle present
                DongleLettre = Left$(Drive.DriveLetter, 1)   ' memorise la lettre du dongle
exit sub
End If

[clemclem2121]

Bien j'ai remplacer la partie ligne 67 par ton code. Et pour voir les erreur j'ai remplacer les cdm.quit par différente boite de dialogue.

Et toujours le même problème. Avec un valeur de numérosérieUSB composé exclusivement de chiffres il m'affiche bien le message d'erreur

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

  Msg = MsgBox("Il y a un problème avec le lecteur " & Drive & vbCrLf & "Erreur: " & Err.DESCRIPTION, vbInformation + vbOKOnly, "Erreur disque")

Puis quand je change et que je met le bon numéro de série ("20044526920F55C0359E") dans mon code. Il s’arrête automatiquement sur le premier msgbox "quit application".

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
 
Private Sub Commande0_Click()
'************ Tester si la clé est presente au démarrage ************
 
    NumSerieUSB = "20044526920F55C0359E"              ' Numéro de série de la clé USB
    DongleOK = False        ' Met le Dongle absent
    Scan_Dongle             ' Va à la procédure Scan du dongle et 
    If DongleOK = False Then 'comme il ne trouve pas le dongle il me le met toujour false et donc il m'affiche
    MsgBox ("Quit l'application")
    Exit Sub
    End If
End Sub

Voila la suite du code l'erreur proviendrai donc de cette partie du code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Scan_Dongle()
    On Error GoTo Err
    If DongleOK = True Then
    MsgBox ("ouvrir le formulaire")
        Exit Sub    ' si Dongle déja présent pas de scan
    End If
 
    ' Retrouver le dongle et son numéro de serie
    Set fso = New FileSystemObject
    For Each Drive In fso.Drives
        If Drive.IsReady = True And Drive.DriveLetter <> "c:" And Drive.DriveLetter <> "d:" Then
        If NumSerieUSB = Drive.SerialNumber Then
        DongleOK = True                     ' dongle present
        DongleLettre = Left$(Drive.DriveLetter, 1)   ' memorise la lettre du dongle

Des pistes de solution cela ne viendrai-t-il pas que sur mon ordinateur les clé son sur les port G et H ?

[LedZeppII]

Bonjour,

Le code que tu utilises s'appuie sur un numéro de série créé par Windows lors du formatage.
Ce n'est pas le numéro de série de la clé.

Je ne sais pas récupérer directement le numéro de série d'une clé USD, mais je sais récupérer un identificateur qui inclus le numéro de série, via WMI (Windows Management Instrumentation).

Code exemple:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
Sub TestGetPhysicalDrives()
Dim arrVarPnpIDs As Variant
Dim sList As String, lIdx As Long
 
arrVarPnpIDs = GetDrivesPNPIDs()
 
If IsNull(arrVarPnpIDs) Then
   MsgBox "Aucun disque n'a pû être trouvé", vbExclamation
Else
   For lIdx = LBound(arrVarPnpIDs) To UBound(arrVarPnpIDs)
       sList = sList & arrVarPnpIDs(lIdx) & vbCrLf
   Next
   MsgBox "Liste des disques:" & vbCrLf & sList, vbInformation
End If
 
End Sub
 
 
Function GetDrivesPNPIDs() As Variant
Dim strComputer As String, sReq As String, sClass As String
Dim objWMIService As Object, colItems As Object, objItem As Object
Dim arrPnpIDs() As String, lIdx As Long
 
On Error GoTo ErrH
 
strComputer = "."
sClass = "Win32_DiskDrive"
sReq = "Select * from " & sClass
 
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery(sReq)
 
If colItems.Count > 0 Then
    ReDim arrPnpIDs(1 To colItems.Count)
    For Each objItem In colItems
        lIdx = lIdx + 1
        arrPnpIDs(lIdx) = objItem.PNPDeviceID
    Next
End If
 
ExitR:
    Set objItem = Nothing
    Set colItems = Nothing
    Set objWMIService = Nothing
    If (lIdx > 0) Then
       GetDrivesPNPIDs = arrPnpIDs
    Else
       GetDrivesPNPIDs = Null
    End If
    Exit Function
 
ErrH:
    MsgBox "Erreur No." & Err.Number & ": " & Err.Description, vbExclamation
    Resume ExitR
End Function

Exécute la procédure TestGetPhysicalDrives pour voir ce qu'elle affiche dans la boîte de message.
Les disques et clés USD apparaissent sous la forme:
USBSTOR\DISK&VEN_XXXXXXXX&PROD_XXXXX&REVXXXXX\XXXXXXXX
Le numéro de série est vers la fin.
Toujours est-il que cette chaîne de caractères (PNPDeviceID), peut représenter un moyen d'identifier la présence de ta clé.
Si bien sûr son format est indépendant de la version de Windows.

A+

[clemclem2121]

Malheureusement pour moi je suis hélas un novice. Le code de LedZeppII fonctionne très bien. Il m'indique bien ma clé USB et le bon numéro de série. Il m'indique aussi mon lecteur de CD. Peut on se limiter à trouver uniquement les infos des clé USB ?

J'essaye de compiler les deux code pour voir si je peux créer quelquechose.

[LedZeppII]

Bonsoir,

Il suffit de parcourir la liste retournée par GetDrivesPNPIDs() et de chercher si un des éléments de la liste contient le numéro de série.

On va faire plus simple en créant une fonction basée sur le principe de GetDrivesPNPIDs().
Cette fonction renverra Vrai si le numéro de série est trouvé, et Faux dans le cas contraire.
Voici le code:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
' -------------------------------------------------------------------
' Cherche la présence d'une clé USB par son numéro de série
' -------------------------------------------------------------------
Function ClePresente(sSN As String) As Boolean
Dim strComputer As String, sReq As String, sClass As String
Dim objWMIService As Object, colItems As Object, objItem As Object
Dim sPnPid As String, bSNtrouve As Boolean
 
On Error GoTo ErrH
 
bSNtrouve = False
strComputer = "."
sClass = "Win32_DiskDrive"
sReq = "Select * from " & sClass
 
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery(sReq)
 
If colItems.Count > 0 Then
   For Each objItem In colItems
       sPnPid = objItem.PNPDeviceID
       ' Teste si l'identificateur de disque contient le numéro
       ' de série recherché, après le 2e antislash
       If sPnPid Like "USB*\*\*" & sSN & "*" Then
          bSNtrouve = True
          Exit For
       End If
   Next
End If
 
ExitR:
    Set objItem = Nothing
    Set colItems = Nothing
    Set objWMIService = Nothing
    ' Valeur à retourner
    ClePresente = bSNtrouve
    Exit Function
 
ErrH:
    MsgBox "Erreur No." & Err.Number & ": " & Err.Description, vbExclamation
    Resume ExitR
End Function

Exemple d'utilisation de la fonction ClePresente():

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub TestPresenceCle()
Dim sNumeroSerie As String
 
' Numéro de série disque USB recherché
sNumeroSerie = "AA000123465"
 
If ClePresente(sNumeroSerie) Then
   MsgBox "La clé est branchée", vbInformation
Else
   MsgBox "La clé n'a pas été trouvée", vbExclamation
End If
End Sub

A+

[clemclem2121]

J'ai rentré votre code le problème c'est que lors de l'exécution il m'indique sur la ligne :
ClePresente = bSNtrouve
le message suivant :
Erreur de compilation.
un appel de fonction dans la partie gauche de l'affectation doit renvoyer Variant ou Objet.

D'ou viens mon erreur dans mon code.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Function ClePresente() As Boolean
Dim strComputer As String, sReq As String, sClass As String
Dim objWMIService As Object, colItems As Object, objItem As Object
Dim sPnPid As String, bSNtrouve As Boolean
 
Private Sub Commande3_Click()
 On Error GoTo ErrH
 
bSNtrouve = False
strComputer = "."
sClass = "Win32_DiskDrive"
sReq = "Select * from " & sClass
 
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery(sReq)
 
If colItems.Count > 0 Then
   For Each objItem In colItems
       sPnPid = objItem.PNPDeviceID
       ' Teste si l'identificateur de disque contient le numéro
       ' de série recherché, après le 2e antislash
       If sPnPid Like "USB*\*\*" & sSN & "*" Then
          bSNtrouve = True
          Exit For
       End If
   Next
End If
 
ExitR:
    Set objItem = Nothing
    Set colItems = Nothing
    Set objWMIService = Nothing
    ' Valeur à retourner
    ClePresente = bSNtrouve
    Exit Function
 
ErrH:
    MsgBox "Erreur No." & Err.Number & ": " & Err.DESCRIPTION, vbExclamation
    Resume ExitR
End Function
 
 
Sub TestPresenceCle()
Dim sNumeroSerie As String
 
' Numéro de série disque USB recherché
sNumeroSerie = "AA000123465"
 
If ClePresente(sNumeroSerie) Then
   MsgBox "La clé est branchée", vbInformation
Else
   MsgBox "La clé n'a pas été trouvée", vbExclamation
End If
End Sub

[micniv]

Salut, clemcmem

efface vite la ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Private Sub Commande3_Click()

[LedZeppII]

Bonsoir,

En plus de l'erreur relevée par Micniv, je constate que tu as mal recopié le code:
La fonction ClePresente a un argument (sSN As String).

Dans un premier temps, copier puis coller le code de la fonction ClePresente dans un module de code.
Code de la fonction:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Function ClePresente(sSN As String) As Boolean
Dim strComputer As String, sReq As String, sClass As String
Dim objWMIService As Object, colItems As Object, objItem As Object
Dim sPnPid As String, bSNtrouve As Boolean
 
On Error GoTo ErrH
 
bSNtrouve = False
strComputer = "."
sClass = "Win32_DiskDrive"
sReq = "Select * from " & sClass
 
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery(sReq)
 
If colItems.Count > 0 Then
   For Each objItem In colItems
       sPnPid = objItem.PNPDeviceID
       ' Teste si l'identificateur de disque contient le numéro
       ' de série recherché, après le 2e antislash
       If sPnPid Like "USB*\*\*" & sSN & "*" Then
          bSNtrouve = True
          Exit For
       End If
   Next
End If
 
ExitR:
    Set objItem = Nothing
    Set colItems = Nothing
    Set objWMIService = Nothing
    ' Valeur à retourner
    ClePresente = bSNtrouve
    Exit Function
 
ErrH:
    MsgBox "Erreur No." & Err.Number & ": " & Err.Description, vbExclamation
    Resume ExitR
End Function

Ensuite, quand tu veux vérifier la présence de la clé par son numéro de série, tu appelles la fonction en lui fournissant le numéro de série à trouver.
Par exemple, si le numéro de série recherché est AA000123465:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Dim sNumeroSerie As String
 
' Numéro de série disque USB recherché
sNumeroSerie = "AA000123465"
 
If ClePresente(sNumeroSerie) Then
   MsgBox "La clé est branchée", vbInformation
Else
   MsgBox "La clé n'a pas été trouvée", vbExclamation
End If

A+