Forum

Forumlar
Kaynaklar
İpucu
Excel'de Görev...
 
Bildirimler
Hepsini Temizle

Excel'de Görev Yöneticisi - Task Manager

 
İpucu
Son Cevaplar gön: Rıza ŞAHAN 11 yıl önce
2 Yazılar
2 Üyeler
0 Reactions
1,446 Görüntüleme
RSS
 Anonim
(@Anonim)
Gönderiler: 0
Konu başlatıcı
 

[b]Excel[/b]'de kendi [b]Görev Yönetici[/b]nizi hazırlamak ve istediğiniz işlem ya da görevi sonlandırmak için aşağıda vereceğim kodları kullanabilirsiniz.

 

[img] [/img]

 

Gerekli Nesneler
■ UserForm
■ 1 Adet MultiPage
■ 2 Adet ListBox
■ 2 Adet CommandButton
■ 1 Adet Label 

 

■ Module1 kodları; 

Private Const TH32CS_SNAPHEAPLIST = &H1
Private Const TH32CS_SNAPPROCESS = &H2
Private Const TH32CS_SNAPTHREAD = &H4
Private Const TH32CS_SNAPMODULE = &H8
Private Const TH32CS_INHERIT = &H80000000
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1&
Private Const PROCESS_TERMINATE = &H1
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const THREAD_SUSPEND_RESUME = &H2
Private Const TOKEN_QUERY = &H8
Private Const TokenUser = 1

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

Private Type THREADENTRY32
    dwSize As Long
    cntUsage As Long
    th32ThreadID As Long
    rh32OwnerProcessID As Long
    tpBasePri As Long
    tpDeltaPri As Long
    dwFlags As Long
End Type

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, sPE32 As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, sPE32 As PROCESSENTRY32) As Long
Private Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Boolean, ByVal dwProcId As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function Thread32First Lib "kernel32" (ByVal hSnapshot As Long, uProcess As THREADENTRY32) As Long
Private Declare Function Thread32Next Lib "kernel32" (ByVal hSnapshot As Long, uProcess As THREADENTRY32) As Long
Private Declare Function OpenThread Lib "Kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Boolean, ByVal dwThreadId As Long) As Long
Private Declare Function SuspendThread Lib "Kernel32.dll" (ByVal hThread As Long) As Integer
Private Declare Function ResumeThread Lib "Kernel32.dll" (ByVal hThread As Long) As Integer
Private Declare Function OpenProcessToken Lib "advapi32.dll" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, ByRef TokenHandle As Long) As Long
Private Declare Function GetTokenInformation Lib "advapi32.dll" (ByVal TokenHandle As Long, ByVal TokenInformationClass As Long, TokenInformation As Any, ByVal TokenInformationLength As Long, ByRef ReturnLength As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef pTo As Any, ByRef uFrom As Any, ByVal lSize As Long)
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function LookupAccountSid Lib "advapi32.dll" Alias "LookupAccountSidA" (ByVal lpSystemName As String, ByVal Sid As Long, ByVal name As String, cbName As Long, ByVal ReferencedDomainName As String, cbReferencedDomainName As Long, peUse As Long) As Long
   
Private Function GetProcessOwner(ByVal lProcessID As Long) As String
    Dim hProcess As Long
    Dim hToken As Long
    Dim lNeeded As Long
    Dim abBuffer() As Byte
    Dim lpSid As Long
    Dim lpString As Long
    Dim strAccountName As String
    Dim lAccountName As Long
    Dim strDomainName As String
    Dim lDomainName As Long
    Dim peUse As Long
   
    GetProcessOwner = "Unknown"
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 0, lProcessID)
    If hProcess <> 0 Then
        If OpenProcessToken(hProcess, TOKEN_QUERY, hToken) <> 0 Then
            GetTokenInformation hToken, TokenUser, 0, 0, lNeeded
            ReDim abBuffer(0 To lNeeded)
            If GetTokenInformation(hToken, TokenUser, abBuffer(0), UBound(abBuffer), lNeeded) = 1 Then
                CopyMemory lpSid, abBuffer(0), 4
                strAccountName = Space(MAX_PATH)
                strDomainName = Space(MAX_PATH)
                lAccountName = MAX_PATH
                lDomainName = MAX_PATH
                If LookupAccountSid(vbNullString, lpSid, strAccountName, lAccountName, strDomainName, lDomainName, peUse) <> 0 Then
                    If strDomainName = "" Then
                        GetProcessOwner = Left(strAccountName, lAccountName)
                    Else
                        GetProcessOwner = Left(strDomainName, lDomainName) & "\" & Left(strAccountName, lAccountName)
                    End If
                End If
            End If
            Call CloseHandle(hToken)
        End If
        CloseHandle hProcess
    End If
End Function

Private Sub ProcessListToSheet(oCell)
    Dim hSnapshot As Long
    Dim sPE32 As PROCESSENTRY32
    Dim lRet As Long
    Dim strProcess As String
    Dim iIter As Integer
    Dim iColumn As Integer
    Dim iPositionNull As Integer
    
    hSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0&)
    
    If hSnapshot <> INVALID_HANDLE_VALUE Then
        sPE32.dwSize = Len(sPE32)
        lRet = Process32First(hSnapshot, sPE32)
        
        iIter = oCell.Row
        iColumn = oCell.Column
        Do While lRet
            iPositionNull = InStr(1, sPE32.szExeFile, Chr(0))
            If iPositionNull > 0 Then
                strProcess = Left(sPE32.szExeFile, iPositionNull - 1)
            Else
                strProcess = ""
            End If
            Cells(iIter, iColumn).Value = strProcess
            Cells(iIter, iColumn + 1).Value = sPE32.th32ProcessID
            Cells(iIter, iColumn + 2).Value = GetProcessOwner(sPE32.th32ProcessID)
            iIter = iIter + 1
            lRet = Process32Next(hSnapshot, sPE32)
        Loop
        
        CloseHandle hSnapshot
    End If
End Sub

Private Sub SuspendProcessByID(ByVal lProcessID As Long, ByVal bSuspend As Boolean)
    Dim hSnapshot As Long
    Dim sTE32 As THREADENTRY32
    Dim hThread As Long
    Dim lRet As Long

    hSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPTHREAD, 0&)
    
    If hSnapshot <> INVALID_HANDLE_VALUE Then
        sTE32.dwSize = Len(sTE32)
        lRet = Thread32First(hSnapshot, sTE32)
        
        Do While lRet
            If sTE32.rh32OwnerProcessID = lProcessID Then
                hThread = OpenThread(THREAD_SUSPEND_RESUME, False, sTE32.th32ThreadID)
                If hThread <> 0 Then
                    If bSuspend Then
                        SuspendThread hThread
                    Else
                        ResumeThread hThread
                    End If
                    CloseHandle hThread
                End If
            End If
            lRet = Thread32Next(hSnapshot, sTE32)
        Loop
        
        CloseHandle hSnapshot
    End If
End Sub

Private Sub TerminateProcessByID(ByVal lProcessID As Long)
    Dim hProcess As Long

    hProcess = OpenProcess(PROCESS_TERMINATE, 0, lProcessID)
    If hProcess <> 0 Then
        TerminateProcess hProcess, 0
        CloseHandle hProcess
    End If
End Sub

Private Sub ExecuteCommands(oCell)
    Dim iIter As Integer
    Dim iColumn As Integer
    
    iIter = oCell.Row
    iColumn = oCell.Column
    Do While Cells(iIter, iColumn + 1).Value <> ""
        Select Case LCase(Cells(iIter, iColumn).Value)
            Case "t":
                TerminateProcessByID Cells(iIter, iColumn + 2).Value
            Case "s":
                SuspendProcessByID Cells(iIter, iColumn + 2).Value, True
            Case "r":
                SuspendProcessByID Cells(iIter, iColumn + 2).Value, False
        End Select
        iIter = iIter + 1
    Loop
End Sub

Sub MacroProcessList()
    Application.ScreenUpdating = False
    Range("A7:D65000").ClearContents
    ProcessListToSheet Range("B7")
    Range("A6:D65000").Sort "Yansıma Adı", xlAscending, header:=xlYes
    Application.ScreenUpdating = True
End Sub

Sub MacroExecuteCommands()
    ExecuteCommands Range("A7")
End Sub


Sub Evn()
    UserForm1.Show
End Sub 
 
 
 
■ Module2 kodları; 
 
  

Private Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Private Declare Function CloseHandle Lib "Kernel32.dll" (ByVal Handle As Long) As Long
Private Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function EnumProcesses Lib "psapi.dll" (ByRef lpidProcess As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Private Declare Function GetModuleFileNameExA Lib "psapi.dll" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As String, ByVal nSize As Long) As Long
Private Declare Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) 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
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Const PROCESS_TERMINATE = &H1
Private Const VER_PLATFORM_WIN32_WINDOWS = 1
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_READ = 16
Private Const TH32CS_SNAPPROCESS = &H2
Private Function CheckVersion() As Long
Dim tOS As OSVERSIONINFO
tOS.dwOSVersionInfoSize = Len(tOS)
Call GetVersionEx(tOS)
CheckVersion = tOS.dwPlatformId
End Function
Private Function GetEXEProcessID(ByVal sEXE As String) As Long
Dim aPID() As Long
Dim lProcesses As Long
Dim lProcess As Long
Dim lModule As Long
Dim sName As String
Dim iIndex As Integer
Dim bCopied As Long
Dim lSnapShot As Long
Dim tPE As PROCESSENTRY32
Dim bDone As Boolean
If CheckVersion() = VER_PLATFORM_WIN32_WINDOWS Then
lSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
If lSnapShot < 0 Then Exit Function
tPE.dwSize = Len(tPE)
bCopied = Process32First(lSnapShot, tPE)
Do While bCopied
sName = Left$(tPE.szExeFile, InStr(tPE.szExeFile, Chr(0)) - 1)
sName = Mid(sName, InStrRev(sName, "\") + 1)
If InStr(sName, Chr(0)) Then
sName = Left(sName, InStr(sName, Chr(0)) - 1)
End If
bCopied = Process32Next(lSnapShot, tPE)
If StrComp(sEXE, sName, vbTextCompare) = 0 Then
GetEXEProcessID = tPE.th32ProcessID
Exit Do
End If
Loop
Else
ReDim aPID(255)
Call EnumProcesses(aPID(0), 1024, lProcesses)
lProcesses = lProcesses / 4
ReDim Preserve aPID(lProcesses)
For iIndex = 0 To lProcesses - 1
lProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, aPID(iIndex))
If lProcess Then
If EnumProcessModules(lProcess, lModule, 4, 0&) Then
sName = Space(260)
Call GetModuleFileNameExA(lProcess, lModule, sName, Len(sName))
If InStr(sName, "\") > 0 Then
sName = Mid(sName, InStrRev(sName, "\") + 1)
End If
If InStr(sName, Chr(0)) Then
sName = Left(sName, InStr(sName, Chr(0)) - 1)
End If
If StrComp(sEXE, sName, vbTextCompare) = 0 Then
GetEXEProcessID = aPID(iIndex)
bDone = True
End If
End If
CloseHandle lProcess
If bDone Then Exit For
End If
Next
End If
End Function
Public Function TerminateEXE(ByVal sEXE As String) As Boolean
Dim lPID As Long
Dim lProcess As Long
lPID = GetEXEProcessID(sEXE)
If lPID = 0 Then Exit Function
lProcess = OpenProcess(PROCESS_TERMINATE, 0, lPID)
Call TerminateProcess(lProcess, 0&)
Call CloseHandle(lProcess)
TerminateEXE = True
End Function

 

■ Module3 kodları; 

Public Type POINTAPI
    x       As Long
    y       As Long
End Type
Public Type Msg
    hwnd As Long
    Message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type
Public Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, _
                            ByVal hwnd As Long, ByVal wMsgFilterMin As Long, _
                            ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function WaitMessage Lib "user32" () As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, _
ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public Uhwnd As Long 'userformun pencere kimliği (handle ID)
Public interval1 As Long
Public bCancel As Boolean
Public Const WM_MOUSEWHEEL = 522
Private Const PM_REMOVE = &H1
Global liste As Control
'TIMER1 NESNESİ///////////////
Public Sub Timer1baslat(formadi)
Uhwnd = FindWindow(vbNullString, formadi)
If Val(interval1) = 0 Then interval1 = 50 'mouse olayını yakalamak için interval değerini 50 yapıyoruz
SetTimer Uhwnd, 1, interval1, AddressOf i1_Timer
End Sub
Public Sub Timer1durdur()
KillTimer Uhwnd, 1
End Sub
Private Sub i1_Timer(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwtime As Long)
Dim Message As Msg
        On Error Resume Next
        WaitMessage 'mesaj bekleniyor
        If PeekMessage(Message, hwnd, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then '...mouse topunu kullanma olayı
            If Message.wParam > 0 Then
'yukarı
                If liste.TopIndex > 0 Then
                 If liste.TopIndex > 3 Then
                 liste.TopIndex = liste.TopIndex - 5
                    Else
                 liste.TopIndex = 0
                 End If
                End If
            Else
'aşağı
            liste.TopIndex = liste.TopIndex + 5
            End If
        DoEvents
        End If
End Sub

■ UserForm kodları; 

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Private Const EVN_KAPAT = 16
Private Sub CommandButton1_Click()
   
    Dim blnRet As Boolean
    blnRet = TerminateEXE(ListBox1.Value)
    If Not blnRet Then
        MsgBox "Kapatamadım !", vbExclamation + vbMsgBoxRtlReading, "Www.ExcelVBA.Net"
    Else
        MsgBox "Program Kapatıldı !", vbExclamation + vbMsgBoxRtlReading, "Www.ExcelVBA.Net"
    End If
    Unload Me
    Application.Wait Now() + TimeValue("00:00:01")
    Call MacroProcessList
    UserForm1.Show
End Sub
Private Sub GorevYoneticisindenSonlandır(ByVal pencereadi As String)
       Dim pencereHwnd As Long
       pencereHwnd = FindWindow(vbNullString, pencereadi)
       If pencereHwnd <> 0 Then
          PostMessage pencereHwnd, EVN_KAPAT, 0&, 0&
       Else
           MsgBox "Aradığınız türde bir uygulama bulunamadı" & vbCr & _
           "Aranan Uygulama : " & pencereadi, vbExclamation, "Www.ExcelVBA.Net"
       End If
End Sub
Private Sub CommandButton2_Click()
    GorevYoneticisindenSonlandır ListBox2.Value
     MsgBox "Program Kapatıldı !", vbExclamation + vbMsgBoxRtlReading, "Www.ExcelVBA.Net"
    Unload Me
    Application.Wait Now() + TimeValue("00:00:01")
    Call MacroProcessList
    UserForm1.Show
End Sub
Private Sub Label1_Click()
    Dim Evn As Object
    Set Evn = CreateObject("internetexplorer.application")
    Evn.navigate "http://www.excelvba.net"
    Evn.Visible = True
    Set Evn = Nothing
End Sub
Private Sub UserForm_Initialize()
    Call MacroProcessList
    For i = 8 To Range("B65536").End(3).Row
        ListBox1.AddItem Cells(i, 2)
    Next i
    
    Dim xStr As String
    Set Word = CreateObject("Word.Application")
    Set Rng = Range("F1")
    Set Tasks = Word.Tasks
    For Each task In Tasks
        If task.Visible Then
        ListBox2.AddItem task.name
        End If
    Next
    Word.Quit
    
    Set liste = Me.ListBox1
    Module3.interval1 = 50
    Module3.Timer1baslat Me.Caption
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Module3.Timer1durdur
    Range("A7:D65000").ClearContents
End Sub
 Hoşça kalın !

--)(

 

 
Gönderildi : 16/11/2013 17:14

 Rıza ŞAHAN
(@riza-sahan)
Gönderiler: 18032
_
 

Paylaşım için teşekkürler. 

1984 doğumluyum. 4 yaşından bu yana İstanbul’da yaşıyorum. Sırası ile aşağıdaki okullarda eğitim gördüm. Paşaköy ilkokulu (1990-1995) Kartal Zekeriyya Güçer İlköğretim Okulu(1995-1998) Ümraniye Teknik ve Endüstri Meslek Lisesi Bilgisayar Bölümü(1998-2001) Kocaeli Üniversitesi Bilgisayar Programcılığı(2002-2004) Anadolu Ünv. İşletme Fakültesi(2006-2009) Lise yıllarından sonra bir bilgisayar firmasının teknik servisinde mesleğe merhaba dedim. Outsource olarak Citibank ytl ve bina taşınma projesinde yer alarak 8 ay görev yaptım. Bu görevden sonra şu an çalışmakta olduğum yerde bilgi işlem sorumlusu olarak göreve başladım ve 18 yıldır görevimin başındayım.

 
Gönderildi : 17/11/2013 00:11

Forum Jump:
  Önceki Konu
Sonraki Konu  
Paylaş: