Soyez le premier à donner votre avis sur cette source.
Vue 6 896 fois - Téléchargée 418 fois
'Macro Créée par : BigFish_le Vrai (Philippe E) 'le :06-08-2008 'V1.0 ' Option Explicit 'API ouverture processus et ses constantes Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Public Const PROCESS_VM_READ As Long = (&H10) Public Const PROCESS_QUERY_INFORMATION As Long = (&H400) Public Declare Function GetCurrentProcessId Lib "kernel32.dll" () As Long Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long Declare Function GetModuleFileNameEx Lib "psapi.dll" Alias "GetModuleFileNameExA" (ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFilename As String, ByVal nSize As Long) As Long Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long Const PROCESS_TERMINATE As Long = &H1 Public Const MAX_PATH As Integer = 260 Public hProcess As Long 'handle du processus Public bob As Long, CurrentProcessId As Long, ViewOnly As Boolean Function EnumWinProc(ByVal lhWnd As Long, ByVal lParam As Long) As Long '----------------------------------- 'enumeration des processus 'renvoie du/des session(s) excel 'Arret du/des Processus excel caché '----------------------------------- Dim RetVal As Long, ProcessID As Long, ThreadID As Long Dim WinClassBuf As String * 255, WinTitleBuf As String * 255 Dim WinClass As String, WinTitle As String, NomExe As String ' see the Windows Class and Title for each top level Window RetVal = GetClassName(lhWnd, WinClassBuf, 255) WinClass = StripNulls$(WinClassBuf) ' remove extra Nulls & spaces RetVal = GetWindowText(lhWnd, WinTitleBuf, 255) WinTitle = StripNulls$(WinTitleBuf) ' la fenetre(thread principale)est elle visible ? RetVal = IsWindowVisible(lhWnd) ' on recupere l'PID de la fenetre(thread principale) ThreadID = GetWindowThreadProcessId(lhWnd, ProcessID) ' on recupere le nom du thread principale NomExe = GetProcessFileName(ProcessID) With Worksheets("sheet1") If NomExe = "excel.exe" And WinTitle Like "Microsoft Excel*" = True Then ' ecriture des données sur la feuille .Range("A" & bob).Value = NomExe .Range("B" & bob).Value = ProcessID ' on converti le resultat binaire en booleen pour une meilleur lecture .Range("C" & bob).Value = CBool(RetVal * -1) .Range("D" & bob).Value = WinTitle ' si le processus est le processus courant ' on lui applique une mise en forme specifique If ProcessID = CurrentProcessId Then .Range("A" & bob & ":E" & bob).Interior.ColorIndex = 35 .Range("E" & bob).Value = "Current" End If ' si le thread principale d'excel est invisible If RetVal = 0 Then .Range("A" & bob & ":E" & bob).Interior.ColorIndex = 44 If ViewOnly = False Then ' on arrete le processus ' La fonction renvoie 1 si le processus c'est arrete If CloseProcess(ProcessID) = 1 Then .Range("E" & bob).Value = "Killed" Else MsgBox "le process n'a pas pu etre arreté ! ", vbExclamation End If End If End If bob = bob + 1 End If End With CloseHandle hProcess EnumWinProc = True End Function Public Function StripNulls(OriginalStr As String) As String ' This removes the extra Nulls so String comparisons will work If (InStr(OriginalStr, Chr(0)) > 0) Then OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1) End If StripNulls = OriginalStr End Function ' --------------------------------------------- ' Renvoie le Nom du processus ' --------------------------------------------- ' Parametre ' ProcessID : ID du processus ' --------------------------------------------- ' d'apres un code de : MadMatt ' Titre d'origine : Renvoie le chemin complet du processus ' Son Site Perso : http://matthieu.napoli.free.fr ' Le site du code : http://vbsystemlibrary.free.fr/code.php?ID=5 ' --------------------------------------------- Public Function GetProcessFileName(ByVal ProcessID As Long) As String ' Processus 0 If ProcessID = 0 Then GetProcessFileName = "[System Process]" ' Processus 4 ElseIf ProcessID = 4 Then GetProcessFileName = "System" Else ' On cherche son chemin d'accès complet 'Dim hProcess As Long 'handle du processus Dim hModule As Long 'handle du module de l'exe Dim Ret As Long 'résultat ' On demande un handle pour le processus hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ Or PROCESS_TERMINATE, 0&, ProcessID) ' Si erreur (accès refusé) If hProcess Then ' On préformate la chaine GetProcessFileName = Space(MAX_PATH) ' On récupère son nom complet GetModuleFileNameEx hProcess, 0, GetProcessFileName, MAX_PATH ' On ferme le handle ouvert 'CloseHandle hProcess ' On retire le vbNUllChar de fin de chaine GetProcessFileName = Left(GetProcessFileName, InStr(GetProcessFileName, vbNullChar) - 1) 'on extrait le nom de l'Image du processus GetProcessFileName = LCase(Right(GetProcessFileName, InStr(1, StrReverse(GetProcessFileName), "\") - 1)) Exit Function ElseIf hProcess = 0 Then GetProcessFileName = vbNullString End If End If End Function ' --------------------------------------------- ' Termine le processus ' --------------------------------------------- Public Function CloseProcess(ProcessID As Long) As Long 'fermeture du thread principal d'excel CloseProcess = TerminateProcess(hProcess, 0) End Function
Un de plus pour confirmer que ça sert! j'ai adapté ce code à une application qui me posait quelques problèmes de nettoyage en cas de fermeture anormale et cela fonctionne très bien.
Merci !
aljan
apparemment certain d'entre vous rencontre un probleme lors de l'ouverture du fichier. Ce probleme provoquerait la fermeture d'excel.
Si vous rencontrez ce probleme merci de m'en fair part ici ou par MP
Amicalement,
3ddI7IHd
merci pour tes encouragements ^^
Amicalement,
3ddI7IHd
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.