FECHAR UM PROGRAMA EM EXECUCAO NO WINDOWS

Option Explicit

Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal dwIdProc As Long) As Long
Private Declare Function Process32First Lib "kernel32" (ByVal hndl As Long, ByRef pstru As PROCESSENTRY32) As Boolean
Private Declare Function Process32Next Lib "kernel32" (ByVal hndl As Long, ByRef pstru As PROCESSENTRY32) As Boolean
Private Declare Function CloseHandle Lib "kernel32" (ByVal hnd As Long) As Boolean
Private Declare Function GetLastError Lib "kernel32" () 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 GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

Private Const TH32CS_SNAPPROCESS = &H2
Private Const PROCESS_TERMINATE = &H1
Private lExitCode As Long

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 * 260
End Type


'FUNCOES AUXILIARES ################################################################

'Atualiza a lista de processos
Public Function ListaProcessos() As Variant
  Dim nLen     As Integer
  Dim bRet     As Boolean
  Dim hSnap    As Long
  Dim nCont    As Long
  Dim Processo As PROCESSENTRY32
  
  
  Dim aNome    As Variant
  Dim aPath    As Variant
  Dim aResp    As Variant
  
  nCont = 0
  ReDim aNome(0) As String
  ReDim aPath(0) As String
  
  hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
  Processo.dwSize = Len(Processo)
  bRet = Process32First(hSnap, Processo)
  If bRet Then
     ReDim Preserve aNome(0) As String
     ReDim Preserve aPath(0) As String
     aNome(nCont) = GetNome(Trim(Processo.szExeFile))
     aPath(nCont) = GetPath(Trim(Processo.szExeFile))
  End If
  Do While bRet
     nCont = nCont + 1
     bRet = Process32Next(hSnap, Processo)
     If bRet Then
        ReDim Preserve aNome(0 To nCont) As String
        ReDim Preserve aPath(0 To nCont) As String
        aNome(nCont) = GetNome(Trim(Processo.szExeFile))
        aPath(nCont) = GetPath(Trim(Processo.szExeFile))
     End If
     DoEvents
  Loop
  bRet = CloseHandle(hSnap)
  
  ReDim aResp(LBound(aNome) To UBound(aNome), 0 To 1) As String
  For nCont = LBound(aNome) To UBound(aNome)
      aResp(nCont, 0) = aNome(nCont)
      aResp(nCont, 1) = aPath(nCont)
  Next
  
  ListaProcessos = aResp
  
End Function

'Finaliza um processo
Public Function KillProcesso(ByVal sArquivo As String) As Boolean
  Dim bFind    As Boolean
  Dim bRet     As Boolean
  Dim hSnap    As Long
  Dim hProcess As Variant
  Dim p32stru  As PROCESSENTRY32
  bFind = False
  hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
  p32stru.dwSize = Len(p32stru)
  bRet = Process32First(hSnap, p32stru)
  If bRet Then If GetNome(Trim(p32stru.szExeFile)) = sArquivo Then bFind = True
  Do While (Not bFind) And (bRet)
     bRet = Process32Next(hSnap, p32stru)
     If bRet Then If UCase(GetNome(Trim(p32stru.szExeFile))) = UCase(sArquivo) Then bFind = True
     DoEvents
  Loop
  bRet = CloseHandle(hSnap)
  KillProcesso = True
  If bFind Then
     hProcess = OpenProcess(PROCESS_TERMINATE, CLng(False), CLng("&h" & Hex$(p32stru.th32ProcessID)))
     If hProcess  0 Then
        If GetExitCodeProcess(hProcess, lExitCode) = 0 Then
           KillProcesso = False
        Else
           If TerminateProcess(hProcess, lExitCode) = 0 Then KillProcesso = False
        End If
     End If
  End If
End Function

Private Function GetNome(ByVal sArq As String) As String
   sArq = LimpaString(sArq, 0)
   Dim ID As Long
   For ID = Len(sArq) To 1 Step -1
       If Mid$(sArq, ID, 1) = "\" Then
          GetNome = Right$(sArq, Len(sArq) - ID)
          Exit For
       End If
   Next ID
   ID = InStr(1, GetNome, ".")
   GetNome = Left(GetNome, ID + 3)
End Function

Private Function GetPath(ByVal sArq As String) As String
   sArq = LimpaString(sArq, 0)
   Dim ID As Long
   For ID = Len(sArq) To 1 Step -1
       If Mid$(sArq, ID, 1) = "\" Then
          GetPath = Left(sArq, ID)
          Exit For
       End If
   Next ID
End Function

Private Function LimpaString(ByVal sArq As String, ByVal nAsc As Byte) As String
   Dim ID As Long
   LimpaString = ""
   For ID = 1 To Len(sArq)
       If Asc(Mid(sArq, ID, 1))  nAsc Then LimpaString = LimpaString & Mid(sArq, ID, 1)
   Next ID
End Function