modifier code pour afficher le device id des claviers

Version imprimable

Bonjour,
En partant de ce code (ou autre), est il possible de scanner que les concentrateur hub et les claviers, tout le reste ne m'est pas utile et prend du temps 15'' sur mon PC.
Ce sera utilisé avec Excel 2010/32bits et win10
Code:

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 Sub usb_1() strComputer = "." [A1:B1048576].ClearContents Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2") Set colDevices = objWMIService.ExecQuery _ ("Select * From Win32_USBControllerDevice") i = 1 For Each objDevice In colDevices strDeviceName = objDevice.Dependent strQuotes = Chr(34) strDeviceName = Replace(strDeviceName, strQuotes, "") arrDeviceNames = Split(strDeviceName, "=") strDeviceName = arrDeviceNames(1) Set colUSBDevices = objWMIService.ExecQuery _ ("Select * From Win32_PnPEntity Where DeviceID = '" & strDeviceName & "'") For Each objUSBDevice In colUSBDevices ' WScript.Echo objUSBDevice.Description ' WScript.Echo objUSBDevice.PnPDeviceID ' Changed from Description to PnPDeviceID 'as this script can be altered to return any property 'of the Win32_USBControllerDevice collection. Range(Cells(i, 1), Cells(i, 1)) = objUSBDevice.Description Range(Cells(i, 2), Cells(i, 2)) = objUSBDevice.PNPDeviceID i = i + 1 Next Next End Sub
Voici ce que je voudrais seulement :

Concentrateur USB générique...........USB\VID_05E3&PID_0608\5&2A2B26F7&0&2...............'=>hub
Concentrateur USB générique..........USB\VID_05E3&PID_0608\6&2E00BB6&0&4.....................'=>hub
Périphérique d’entrée USB...............USB\VID_413C&PID_2106\7&22592B1F&0&3...................'=>clavier 1
Périphérique clavier PIH..................HID\VID_413C&PID_2106\8&3663B53&0&0000...............'=>clavier 1
Périphérique d’entrée USB...............USB\VID_413C&PID_2105\6&2E00BB6&0&2....................'=>clavier 2
Périphérique clavier PIH...................HID\VID_413C&PID_2105\7&AF77C65&0&0000..............'=>clavier 2

Merci
Bonne journée

Peut-être avec le code modifié suivant, tu pourras y parvenir ?!

Code:

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
Dim arrDesc, j
arrDesc = Array("Concentrateur USB générique", "Périphérique d’entrée USB", "Périphérique clavier PIH") ' Description des périphériques voulus
 
Sub usb_1()
    strComputer = "."
    [A1:B1048576].ClearContents
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Set colDevices = objWMIService.ExecQuery _
         ("Select * From Win32_USBControllerDevice")
     dim Ret
    i = 1
    For Each objDevice In colDevices
       strDeviceName = objDevice.Dependent
       strQuotes = Chr(34)
       strDeviceName = Replace(strDeviceName, strQuotes, "")
       arrDeviceNames = Split(strDeviceName, "=")
       strDeviceName = arrDeviceNames(1)
       Set colUSBDevices = objWMIService.ExecQuery _
           ("Select * From Win32_PnPEntity Where DeviceID = '" & strDeviceName & "'")
       For Each objUSBDevice In colUSBDevices
          ' WScript.Echo objUSBDevice.Description
          ' WScript.Echo objUSBDevice.PnPDeviceID ' Changed from Description to PnPDeviceID
                                     'as this script can be altered to return any property
                                     'of the Win32_USBControllerDevice collection.
 
            For j = LBound(arrDesc) to UBound(arrDesc)
               If objUSBDevice.Description = arrDesc(j) Then
                 Range(Cells(i, 1), Cells(i, 1)) = objUSBDevice.Description
                 Range(Cells(i, 2), Cells(i, 2)) = objUSBDevice.PNPDeviceID
                 i = i + 1
                 Exit For
               End if
            Next ' j
       Next ' objUSBDevice
    Next    ' objDevice
End Sub

16/02/2017, 20h17
re
Bonjour,
Merci pour ta reponse, oui ça fonctionne mais ça met 17" puisque ça scanne tout alors que le 1er code est presque instantané...

D'autre part j'ai mis les deux 1er lignes sous Sub sinon code erreur, est-ce juste ? Comment résoudre le problème du scan pour plus de réactivité ?
Code:

1 2 3 4 Sub usb_1() Dim arrDesc, j arrDesc = Array("Concentrateur USB générique", "Périphérique d’entrée USB", "Périphérique clavier PIH") ' Description des périphériques voulus
17/02/2017, 11h23
l_autodidacte

Bonjour;
Les variables déclarées en dehors d'une fonction ou Sub (dans la déclaration générale) sont vues par celle-ci et toutes les autres, mais l'inverse est faux.
Tu peux les mettre à l'intérieur de celle-ci sans problème.

Pour la rapidité de retour de Sub_1(), je ne vois pas pour le moment un autre moyen qui y mène, puisque le code doit scanner tous les contrôleurs USB et choisir ceux qui nous intéressent.(On a 3 boucles imbriquées qui ralentissent la recherche).

Peut-être que l'un des membres de ce forum aurait une idée sur ce sujet

Salut

Citation:

Envoyé par l_autodidacte

Bonjour;........
Peut-être que l'un des membres de ce forum aurait une idée sur ce sujet

Code:

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
Sub usb_1()
    arrDesc = Array("Concentrateur USB générique", "Périphérique d’entrée USB", "Périphérique clavier PIH") ' Description des périphériques voulus
    strComputer = "."
    strQuotes = Chr(34)
    '[A1:B1048576].ClearContents
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Set colDevices = objWMIService.ExecQuery _
         ("Select Dependent From Win32_USBControllerDevice")
    i = 1
    For Each objDevice In colDevices
       strDeviceName = (Split(Replace(objDevice.Dependent, strQuotes, ""), "="))(1)
       Set colUSBDevices = objWMIService.ExecQuery _
           ("Select Description, PNPDeviceID From Win32_PnPEntity Where DeviceID = '" & strDeviceName & "'")
       For Each objUSBDevice In colUSBDevices
          ' WScript.Echo objUSBDevice.Description
          ' WScript.Echo objUSBDevice.PnPDeviceID ' Changed from Description to PnPDeviceID
                                     'as this script can be altered to return any property
                                     'of the Win32_USBControllerDevice collection.
 
            For j = LBound(arrDesc) to UBound(arrDesc)
               If objUSBDevice.Description = arrDesc(j) Then
                 'Range(Cells(i, 1), Cells(i, 1)) = objUSBDevice.Description
                 'Range(Cells(i, 2), Cells(i, 2)) = objUSBDevice.PNPDeviceID
                 'i = i + 1
                  List = List & "Description: "  & objUSBDevice.Description & vbnewline & "PNPDeviceID: "  & objUSBDevice.PNPDeviceID
                 Exit For
               End if
            Next ' j
       Next ' objUSBDevice
    Next    ' objDevice
msgbox list
End Sub

En jouant sur le retour de requêtes (Nombre de colonnes renvoyées) et la déclaration en une seule ligne (strDeviceName = ...), sur mon ordinateur, la boucle complète me réduit de moitié le temps.
Pas sûr que sur tous les systèmes cela soit équivalant, mais apparemment il y a bien un gain de temps.

Bien vu ProgElecT :coucou:
Crois-moi, en disant "Peut-être que l'un des membres de ce forum aurait une idée sur ce sujet", j'ai directement pensé à toi

La rapidité vient du fait qu'on sélectionne directement les éléments dont on a besoin :Dependent, Description, PNPDeviceID

Une autre amélioration de la rapidité est de sortir de la boucle For Each objUSBDevice In colUSBDevices juste après Next ' j.
Pour visualiser le résultat, j'inscris le tout dans un fichier texte y compris la durée d'exécution de sub_1 ; voici le code retouché :

Code:

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
Sub usb_1()
    arrDesc = Array("Concentrateur USB générique", "Périphérique d’entrée USB", "Périphérique clavier PIH") ' Description des périphériques voulus
    strComputer = "."
    strQuotes = Chr(34)
    '[A1:B1048576].ClearContents
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
    Set colDevices = objWMIService.ExecQuery _
         ("Select Dependent From Win32_USBControllerDevice")
  '   i = 1
    For Each objDevice In colDevices
       strDeviceName = (Split(Replace(objDevice.Dependent, strQuotes, ""), "="))(1)
       Set colUSBDevices = objWMIService.ExecQuery _
           ("Select Description, PNPDeviceID From Win32_PnPEntity Where DeviceID = '" & strDeviceName & "'")
       For Each objUSBDevice In colUSBDevices
          ' WScript.Echo objUSBDevice.Description
          ' WScript.Echo objUSBDevice.PnPDeviceID ' Changed from Description to PnPDeviceID
                                     'as this script can be altered to return any property
                                     'of the Win32_USBControllerDevice collection.
 
            For j = LBound(arrDesc) to UBound(arrDesc)
               If objUSBDevice.Description = arrDesc(j) Then
                 'Range(Cells(i, 1), Cells(i, 1)) = objUSBDevice.Description
                 'Range(Cells(i, 2), Cells(i, 2)) = objUSBDevice.PNPDeviceID
                 'i = i + 1
                  List = List & "Desc: "  & objUSBDevice.Description & vbTab & "PNPDeviceID: "  & objUSBDevice.PNPDeviceID & vbNewLine
                 Exit For
               End if
            Next ' j
            Exit For ' C'est ici la modification pour un petit gain de temps: sur ma machine on passe de 6 sec à 2 sec
       Next ' objUSBDevice
    Next    ' objDevice
f.Write list 
End Sub
dt0 = Now
set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.OpenTextFile("DvcID.txt", 2, True)
usb_1
dt1 = Now
diff = DateDiff("s", dt0, dt1)
f.write vbNewLine & "Durée : " & diff & " sec"
f.Close
Createobject("Wscript.shell").Run  "DvcID.txt", 1 , False

Mais attention : à la première exécution, cela prend plus de temps qu'à la 2ème

18/02/2017, 13h10
re

Bonjour,
Un grand merci à vous deux pour vous être penchés sur mon p'tit problème ;-)
Sur vos 2 codes j'ai l'erreur à cette ligne :

Code:

strDeviceName = (Split(Replace(objDevice.Dependent, strQuotes, ""), "="))(1)

Elle est rouge et message ''erreur de compilation'' au lancement de la macro, d'autre part n'étant pas spécialiste du VBA, est il normal que le End Sub ne soit pas à la fin du code ?
Tu dis, "j'écris dans un fichier texte", c'est un fichier qui est enregistré ? ou ?
Si le code s'exécute en 2'', je pense que c'est gérable, pour l'instant je ne sais encore s'il faut le lancer à chaque fois qu'un clavier fait une saisie et donc ''Enter'', l'on y va par étape...
Petit rappel si important : Win10 / Excel 2010-32bits / VBA 7.0.1640

Merci encore
Bon WE
18/02/2017, 14h03
ProgElecT

Salut

Citation:

Envoyé par re

Bonjour,
.........
d'autre part n'étant pas spécialiste du VBA, est il normal que le End Sub ne soit pas à la fin du code ?
..............
Petit rappel si important : Win10 / Excel 2010-32bits / VBA 7.0.1640

Merci encore
Bon WE

Les erreurs que tu constates sont surement le fait que l'on t'a proposé un code pour VBScript qui diffère un peu du code d'une macro VBA.
La ligne strDeviceName = (Split(Replace(objDevice.Dependent, strQuotes, ""), "="))(1) fonctionne aussi bien en VBScript que VB6 et antérieur.
Essais >strDeviceName = Split(Replace(objDevice.Dependent, strQuotes, ""), "=")(1), pour VBA cela pourrait peut être passer sans erreur [ (et ) en moins].

Si tu prends le code de l_autodidacte :salut: ,

de la ligne 1 à 33 tu as une sub,
de la ligne 34 à 42 tu à le programme principal qui appel la sub usb_1 à la ligne 37.

Moi pour voir l'amélioration possible de la rapidité du code, je l'ai fait sous VB6 et antérieur, puis retranscrit en VBScript, c'est là que j'ai vue que le code prenait la moitié moins de temps d'exécution.
18/02/2017, 16h51
re

Ca fonctionne avec ceci :

Citation:

strDeviceName = (Split(Replace(objDevice.Dependent, strQuotes, ""), "=")(1))

Il faut supprimer les lignes après End sub pour le VBA 7.0 (celui qui est avec Excel 2010)
Le code s'execute en 5'' avec Exit For et 7'' sans Exit For
Comme vous le savez Wscript et f.write ne sont pas utilisé par ce VBA mais par VBAsript

Les 2 premiers périph s'affichent presque instantanément, c'est le hub externe et les 2 claviers que j'ai branché qui s'affichent après 5".

Peut on dire que l'on veut scanner que les périphs HID\VID ou USB\VID ?
Exemples :
Périphérique d’entrée USB USB\VID_413C&PID_2105\7&18384972&0&4
Périphérique clavier PIH HID\VID_413C&PID_2105\8&7EDBD78&0&0000

Pour l'utilisation de ces infos je pense qu'il va falloir lancer la macro pour chaque appuie sur Enter de chaque clavier ce qui rallonge le traitement et va peut être créer des conflits si l'on appuie en même temps sur les claviers.
Pour 5 claviers ça fait 25 secondes pour avoir un résultat, c'est long !
Qu'en passez vous ? quelles autres solutions ?

Merci