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
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
| Option Compare Database
Option Explicit
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)
Private Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As TOKEN_PRIVILEGES, ReturnLength As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Public Const MAX_PATH As Integer = 260
Public Const TH32CS_SNAPHEAPLIST = &H1
Public Const TH32CS_SNAPPROCESS = &H2
Public Const TH32CS_SNAPTHREAD = &H4
Public Const TH32CS_SNAPMODULE = &H8
Public Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Public Const TH32CS_INHERIT = &H80000000
Private mProcessIDActuel As Long
Private mProcessIDTous(50) As Long
Private mNombreProcessus As Integer
Public 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
Private Type LUID
LowPart As Long
HighPart As Long
End Type
Private Type TOKEN_PRIVILEGES
PrivilegeCount As Long
TheLuid As LUID
Attributes As Long
End Type
Private Function ProcessTerminate(Optional lProcessID As Long, Optional lHwndWindow As Long) As Boolean
Dim lhwndProcess As Long
Dim lExitCode As Long
Dim lRetVal As Long
Dim lhThisProc As Long
Dim lhTokenHandle As Long
Dim tLuid As LUID
Dim tTokenPriv As TOKEN_PRIVILEGES, tTokenPrivNew As TOKEN_PRIVILEGES
Dim lBufferNeeded As Long
Const PROCESS_ALL_ACCESS = &H1F0FFF, PROCESS_TERMINAT = &H1
Const ANYSIZE_ARRAY = 1, TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_QUERY = &H8, SE_DEBUG_NAME As String = "SeDebugPrivilege"
Const SE_PRIVILEGE_ENABLED = &H2
On Error Resume Next
If lHwndWindow Then
'Get the process ID from the window handle
lRetVal = GetWindowThreadProcessId(lHwndWindow, lProcessID)
End If
If lProcessID Then
'Give Kill permissions to this process
lhThisProc = GetCurrentProcess
OpenProcessToken lhThisProc, TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, lhTokenHandle
LookupPrivilegeValue "", SE_DEBUG_NAME, tLuid
'Set the number of privileges to be change
tTokenPriv.PrivilegeCount = 1
tTokenPriv.TheLuid = tLuid
tTokenPriv.Attributes = SE_PRIVILEGE_ENABLED
'Enable the kill privilege in the access token of this process
AdjustTokenPrivileges lhTokenHandle, False, tTokenPriv, Len(tTokenPrivNew), tTokenPrivNew, lBufferNeeded
'Open the process to kill
lhwndProcess = OpenProcess(PROCESS_TERMINAT, 0, lProcessID)
If lhwndProcess Then
'Obtained process handle, kill the process
ProcessTerminate = CBool(TerminateProcess(lhwndProcess, lExitCode))
Call CloseHandle(lhwndProcess)
End If
End If
On Error GoTo 0
End Function
Private Function GetHandleExeName(Handle As Long) As String
Dim tProcName As String
Dim hSnapshot As Long
Dim uProcess As PROCESSENTRY32
Dim r As Long
Dim tPID As Long, Temp As Long
Temp = GetWindowThreadProcessId(Handle, tPID)
mProcessIDActuel = tPID
'Takes a snapshot of the processes
hSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)
'set the length of our ProcessEntry-type
uProcess.dwSize = Len(uProcess)
'Retrieve information about the first process encountered in our system snapshot
uProcess.szExeFile = vbNullString
r = Process32First(hSnapshot, uProcess)
Do While r
If tPID = uProcess.th32ProcessID Then
GetHandleExeName = Trim(Replace(uProcess.szExeFile, Chr(0), ""))
Exit Function
End If
'Retrieve information about the next process recorded in our system snapshot
uProcess.szExeFile = vbNullString
r = Process32Next(hSnapshot, uProcess)
Loop
'close our snapshot handle
GetHandleExeName = "[Pas d'exécutable trouvé]"
CloseHandle hSnapshot
End Function
Private Function RecherchePID(sNomApplication As String)
Dim i As Integer
Dim hSnapshot As Long
Dim uProcess As PROCESSENTRY32
Dim r As Long
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
If hSnapshot = 0 Then Exit Function
uProcess.dwSize = Len(uProcess)
i = 0
mNombreProcessus = 0
r = Process32First(hSnapshot, uProcess)
Do While r
If (Mid(uProcess.szExeFile, 1, Len(sNomApplication)) = sNomApplication) Then
mProcessIDTous(i) = uProcess.th32ProcessID
mNombreProcessus = mNombreProcessus + 1
i = i + 1
End If
r = Process32Next(hSnapshot, uProcess)
Loop
End Function
'---------------------------------------------------------------------------------------
' Procedure : GererInstances
' DateTime : 02/02/2008 15:37
' Author : MICNIV
'---------------------------------------------------------------------------------------
'
' VERIFIER SI une instance de cette appli est déjà lancée
' Si une autre instance de votre programme est trouvée, un message d'alerte
' avertit l'utilisateur, en lui demandant si il veut tuer toutes les autres
' instances de votre programme mais pas celle qu'il vient de lancer ! (kill process)
'
' Vous pouvez donner n'importe quel nom d'executable, celui ci sera automatiquement recherché !
' Je me suis basé sur differents scripts existants sur le site pour les fonctions permettant
' de rechercher le nom de l'executable, de lister les processus, et de kill process !!
' Pour utiliser ce module, vous n'avez qu'une seule fonction a appeler dans votre Form_Load
' Debug.Print " handle appli : " & Me.hwnd
' call GererInstances(Me.hwnd)
'
' REMARQUE : 'En laissant tourner le programme dans un timer ( contrôle toutes les minutes )
' pour vérifier qu'un programme est bien lancé, l'utilisation de la mémoire augmente.
' Je laisse tourner pour voir en combien de temps cela sature :
' En 6h, la mémoire utilisée est passé de 128 à 425.
' Le problème vient à partir de la procédure RecherchePID qui ne doit pas libérer
' la mémoire utilisée ( j'ai isolé cette fonction et depuis plus de pb ).
' Par contre, dans cette fonction je ne vois pas ce qu'il faut fermer en fin de
' procédure pour ne plus avoir ce pb.
Public Function GererInstances(sHandle As Long)
Dim i As Integer
Dim strAppName As String
'On recherche le nom de l'application en cours
strAppName = GetHandleExeName(sHandle)
Debug.Print "GetHandleExeName: " & strAppName
'On recherche tous les process ID lié a l'application courante
RecherchePID (strAppName)
If (mNombreProcessus > 1) Then
If (MsgBox("D'autres processus de cette application " & strAppName & " sont en cours !" & vbCrLf & _
"Voulez-vous terminer ces processus ??", vbOKCancel) = vbOK) Then
For i = 0 To mNombreProcessus - 1
If (mProcessIDTous(i) <> mProcessIDActuel) Then
ProcessTerminate (mProcessIDTous(i))
End If
Next i
End If
End If
End Function |
Eviter le lancement de plusieurs instances de mon application
Répondre avec citation
) et j'ai constaté ceci :
,
Partager