Code d'accès au snapshot du système sous 64 bit

Version imprimable

Bonjour,

J'avais un code d'accès dans une macro Excel à la liste des processus lancés dans le système (en 32 bit). Je suis passé sous windows 7 64 bit. Maintenant ce code ne marche plus. Pourriez-vous me dire comment je peux régler ce problème ? Merci d'avance.

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
43
44
45
46
47
48
49
50
51
52
 
 
Option Explicit
 
Private Const MAX_PATH As Long = 260
 
Private Const TH32CS_SNAPPROCESS As Long = &H2
 
Private Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szExeFile As String * MAX_PATH
End Type
 
 
#If VBA7 Then
 
Private Declare PtrSafe Function CreateToolhelp32Snapshot Lib "KERNEL32.dll" ( _
    ByVal dwFlags As Long, _
    ByVal th32ProcessID As Long) As Long
 
Private Declare PtrSafe Function Process32First Lib "KERNEL32.dll" ( _
     ByVal hSnapshot As Long, _
     ByRef lppe As PROCESSENTRY32) As Long
 
Private Declare PtrSafe Function Process32Next Lib "KERNEL32.dll" ( _
     ByVal hSnapshot As Long, _
     ByRef lppe As PROCESSENTRY32) As Long
 
 
#Else
 
Private Declare Function CreateToolhelp32Snapshot Lib "KERNEL32.dll" ( _
    ByVal dwFlags As Long, _
    ByVal th32ProcessID As Long) As Long
 
Private Declare Function Process32First Lib "KERNEL32.dll" ( _
     ByVal hSnapshot As Long, _
     ByRef lppe As PROCESSENTRY32) As Long
 
Private Declare Function Process32Next Lib "KERNEL32.dll" ( _
     ByVal hSnapshot As Long, _
     ByRef lppe As PROCESSENTRY32) As Long
 
#End If

Procédure d'appel :

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
43
44
45
 
 
Private Sub Workbook_Open()
 
 On Error Resume Next
 
 
    Dim SnapShot As Long
    Dim Proc As Long
    Dim SQL  As String
    Dim ProcessEnt As PROCESSENTRY32
    Dim i As Integer
 
 
   i = 0
 
    SnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
    ProcessEnt.dwSize = Len(ProcessEnt)
 
    Proc = Process32First(SnapShot, ProcessEnt)
    'Liste les processus
    While Proc
      'Pour le processus
      With ProcessEnt
 
     ' Debug.Print StrZToStr(.szExeFile)
 
      If StrZToStr(.szExeFile) = "ADM!R.exe" Then i = 1  'vérification de l'existance d'un exe lancé
 
      End With
 
      'Lire le processus suivant
      Proc = Process32Next(SnapShot, ProcessEnt)
    Wend
 
    If i = 0 Then
 
    Application.Quit
 
    Else
 
 
End If
 
End Sub

Bonjour,

Les api ont légèrement changé, il ne suffit pas de rajouter PtrSafe.
Cordialement
ctac

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
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
Private Const MAX_PATH As Long = 260
'Private Const TH32CS_SNAPPROCESS As Long = &H2
Private Const TH32CS_SNAPPROCESS = &H2
#If VBA7 Then
Private Declare PtrSafe Function CreateToolhelp32Snapshot Lib "KERNEL32.dll" ( _
    ByVal dwFlags As LongPtr, _
    ByVal th32ProcessID As LongPtr) As LongPtr
Private Declare PtrSafe Function Process32First Lib "KERNEL32.dll" ( _
     ByVal hSnapshot As LongPtr, _
     ByRef lppe As PROCESSENTRY32) As Long
Private Declare PtrSafe Function Process32Next Lib "KERNEL32.dll" ( _
     ByVal hSnapshot As LongPtr, _
     ByRef lppe As PROCESSENTRY32) As Long
#Else
Private Declare Function CreateToolhelp32Snapshot Lib "KERNEL32.dll" ( _
    ByVal dwFlags As Long, _
    ByVal th32ProcessID As Long) As Long
Private Declare Function Process32First Lib "KERNEL32.dll" ( _
     ByVal hSnapshot As Long, _
     ByRef lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "KERNEL32.dll" ( _
     ByVal hSnapshot As Long, _
     ByRef lppe As PROCESSENTRY32) As Long
#End If
#If Win64 Then
Private Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32DefaultHeapIDB As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    pcPriClassBaseB As Long
    dwFlags As Long
    szExeFile As String * MAX_PATH
End Type
#Else
Private Type PROCESSENTRY32
    dwSize As Long
    cntUsage As Long
    th32ProcessID As Long
    th32DefaultHeapID As Long
    th32ModuleID As Long
    cntThreads As Long
    th32ParentProcessID As Long
    pcPriClassBase As Long
    dwFlags As Long
    szExeFile As String * MAX_PATH
End Type
#End If
Sub Workbook_Open()
' On Error Resume Next
    Dim SnapShot As LongPtr
    Dim Proc As Long
    Dim SQL  As String
    Dim ProcessEnt As PROCESSENTRY32
    Dim i As Integer
   i = 0
    SnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
    ProcessEnt.dwSize = Len(ProcessEnt)
    Proc = Process32First(SnapShot, ProcessEnt)
    'Liste les processus
    While Proc
      'Pour le processus
      With ProcessEnt
'      Debug.Print StrZToStr(.szExeFile)
      Debug.Print .szExeFile
'      If StrZToStr(.szExeFile) = "ADM!R.exe" Then i = 1  'vérification de l'existance d'un exe lancé
      End With
i = i + 1
      'Lire le processus suivant
      Proc = Process32Next(SnapShot, ProcessEnt)
    Wend
    If i = 0 Then
MsgBox "0"
'    Application.Quit
    Else
End If
End Sub

04/06/2013, 15h35
oreoolep

Réglé

Merci beaucoup. ça marche:D.

cordialement,

Ore