' testProcessLview.bas pour RapidQ-France
' Code par Gérald VERDIER - BinoclaR (°-°) software
' décembre 2006
' email : gerald.verdier@club-internet.fr
' OBJECTIF : Lister les processus en mémoire et afficher les info
'            lancer un nouveau processus et terminer les processus
'            avec affichage des icones éventuels des exe

$include "rapidq.inc"

Const MAX_PATH As Integer = 260
Const TH32CS_SNAPPROCESS As Long = 2
Const PROCESS_QUERY_INFORMATION = 1024
Const PROCESS_VM_READ = 16
const PROCESS_TERMINATE = 1

Type PROCESSENTRY32
    dwSize As Long                    'taille de cette structure (à initialiser avant l'appel à Process32First ou Process32Next)
    cntUsage As Long                  'nombre de handles du processus ouverts
    th32ProcessID As Long             'ID du processus
    th32DefaultHeapID As Long         'interne à windows
    th32ModuleID As Long              'interne à windows
    cntThreads As Long                'nombre de threads du processus
    th32ParentProcessID As Long       'ID du processus parent
    pcPriClassBase As Long            'classe de priorité de base
    dwFlags As Long                   'réservé
    szexeFile As String * MAX_PATH    'NT/2000/XP : nom du fichier Exe (sans le chemin)
                                      '9x/ME : chemin et nom du fichier Exe
End Type    

Dim uProcess As PROCESSENTRY32

Type PROCESS_MEMORY_COUNTERS
    cb As Long
    PageFaultCount As Long
    PeakWorkingSetSize As Long
    WorkingSetSize As Long
    QuotaPeakPagedPoolUsage As Long
    QuotaPagedPoolUsage As Long
    QuotaPeakNonPagedPoolUsage As Long
    QuotaNonPagedPoolUsage As Long
    PagefileUsage As Long
    PeakPagefileUsage As Long
End Type    

Dim pmc As PROCESS_MEMORY_COUNTERS

Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
End Type

Type SYSTEMTIME
    wYear As Word
    wMonth As Word
    wDayOfWeek As Word
    wDay As Word
    wHour As Word
    wMinute As Word
    wSecond As Word
    wMilliseconds As Word
End Type

Dim FT0 As FILETIME, FT1 As FILETIME, ST As SYSTEMTIME

TYPE STARTUPINFO
	cb AS LONG
	lpReserved AS LONG
	lpDesktop AS LONG
	lpTitle AS LONG
	dwX AS LONG
	dwY AS LONG
	dwWidth AS LONG
	dwHeight AS LONG
	dwCharWidth AS LONG
	dwCharHeight AS LONG
	dwFillAttribs AS LONG
	dwFlags AS LONG
	wShowWindow AS LONG
	cbReserved2 AS LONG
	lpReserved2 AS LONG
	hStdInput AS LONG
	hStdOutput AS LONG
	hStdError AS LONG
END TYPE

DIM si AS STARTUPINFO

TYPE PROCESS_INFORMATION
	hProcess AS LONG
	hThread AS LONG
	dwPID AS LONG
	dwTID AS LONG
END TYPE

DIM pi AS PROCESS_INFORMATION
WITH si
	.cb = SIZEOF(si)
	.lpReserved = NULL
	.lpDesktop = NULL
	.lpTitle = NULL
	.dwX = 0
	.dwY = 0
	.dwWidth = 0
	.dwHeight = 0
	.dwCharWidth = 0
	.dwCharHeight = 0
	.dwFillAttribs = 0
	.dwFlags = STARTF_USESHOWWINDOW
	.wShowWindow = SW_NORMAL         
	.cbReserved2 = 0
    .lpReserved2 = NULL
    .hStdInput = NULL
    .hStdOutput = NULL
    .hStdError = NULL
END WITH

'pour mémoriser les types
DIM siMem AS QMEMORYSTREAM, piMem AS QMEMORYSTREAM 


DEFSTR appName$ =  "", cmdLine$ = "", cDir$ = ""

Declare Function GetProcessTimes Lib "kernel32" Alias "GetProcessTimes" (ByVal hProcess As Long, lpCreationTime As FILETIME, lpExitTime As FILETIME, lpKernelTime As FILETIME, lpUserTime As FILETIME) As Long
Declare Function FileTimeToLocalFileTime Lib "kernel32" Alias "FileTimeToLocalFileTime" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Declare Function FileTimeToSystemTime Lib "kernel32" Alias "FileTimeToSystemTime" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long

Declare Function GetCurrentProcessId Lib "kernel32" Alias "GetCurrentProcessId" () As Long
DECLARE FUNCTION CreateProcess LIB "kernel32" ALIAS "CreateProcessA" (BYREF applicationName AS STRING, BYREF commandLine AS STRING, processAttribs AS LONG, threadAttribs AS LONG, inheritHandles AS LONG, flags AS LONG, enviroment AS LONG, BYREF currentDirectory AS STRING, lpStartupInfoStruct AS LONG, lpProcessInformationStruct AS LONG) AS LONG

Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (lFlags As Long, lProcessID As Long) As Long
Declare Function GetProcessMemoryInfo Lib "PSAPI.DLL" Alias "GetProcessMemoryInfo" (hProcess As Long, ppsmemCounters As PROCESS_MEMORY_COUNTERS, cb As Long) As Long
Declare Function OpenProcess Lib "kernel32" Alias "OpenProcess" (dwDesiredAccess As Long, bInheritHandle As Long, dwProcessId As Long) As Long
Declare Function CloseHandle Lib "kernel32" Alias "CloseHandle" (hObject As Long) As Long
Declare Function TerminateProcess Lib "kernel32" Alias "TerminateProcess" (hThread As Long, dwExitCode As Long) As Long

Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (hInst As Long,lpszExeFileName As String,nIconIndex As Long) As Long
Declare Function DestroyIcon Lib "user32" Alias "DestroyIcon" (hIcon As Long) As Long
Declare Function DrawIcon Lib "user32" Alias "DrawIcon" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long    


Declare sub ProcessList 'listage des processus
Declare sub finProcess (sender as QListView) 'arrêt d'un processus
Declare sub createP 'lancement d'un processus
Declare sub icoProcess(sender as QListView) 'extraction de l'icone de l'exe
Declare sub actualiser 'actualisation des listes

Dim pFont as QFont
pFont.size = 8
pFont.name = "Courier new"

Dim icoBitMap as QBitmap
icoBitMap.bmp = "genico.bmp" 'bmp remplace l'icone absent

DIM prTimer as QTimer 'timer de boucle de surveillance process
prTimer.enabled = 1
prTimer.interval = 100
prTimer.onTimer = processList
Dim x as byte
Dim ic as byte
Dim cnt as byte

DIM ListTimeF AS QStringList 'liste en mémoire des temps de démarrage
DIM ListIdF AS QStringList   'liste en mémoire des identifiants
DIM ListMemF AS QStringList  'liste en mémoire des utilisations mémoire
DIM ListNomF AS QStringList  'liste en mémoire des noms de process


CREATE Form AS QFORM
    caption = "Gestionnaire des processus de Windows"
    Width = 600
    Height = 570    
    Center
    borderStyle = 3
    onShow = ProcessList
    CREATE processView as QListView
        left = 5
        top = 5
        width = 585
        height = 480
        font = pFont
        ColumnClick = 0 
        ReadOnly = 1 
        RowSelect = 1 
        Gridlines = 0 
        ViewStyle = vsReport
        ShowColumnHeaders = 1
        AddColumns "Processus","Util.Mem","Id","Démarrage"               
        Column(0).Width = 170
        Column(1).Width = 80
        Column(2).Width = 60 
        Column(3).Width = 250    
        onDblClick = finProcess  
        onClick = icoProcess
    END CREATE
    CREATE finBTN as QButton
        caption = "Terminer le processus"
        left = 480
        width = 110
        height = 20
        top = 491      
        onClick =  finProcess 
    END CREATE 
    CREATE frBTN as QButton
        caption = "Actualiser"
        left = 420
        width = 55
        top = 491
        height = 20
        onClick = actualiser
    END CREATE                
    CREATE Pcanvas AS QCANVAS
        left = 330
        top = 487
        width = 90
        height = 32        
    END CREATE      
    CREATE PButton as QButton
        top = 491
        left = 256
        width = 70
        height = 20
        caption = "Exécuter :"
        onClick = createP 
    END CREATE    
    CREATE pEdit as QEdit
        left = 5         
        top = 490
        width = 250
    END CREATE      
    CREATE StatusBar AS QSTATUSBAR
        AddPanels "",""
        Panel(0).Width = (form.width/2)-100
        Panel(0).Alignment = taCenter  
        Panel(1).Alignment = taCenter  
    END CREATE     
END CREATE
'===================================
sub ProcessList  'sans clignotement des listes (cause actualisation des données)     
    listNomF.clear 'rafraichissement des listes en mémoire 
    ListMemF.clear
    ListIdF.clear
    ListTimeF.clear     
    
    Dim hSnapshot As Long
    Dim g as long  
    Dim r As Long
    Dim cnt as byte
    
    hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0)  'capture process 
    If hSnapshot = 0 Then Exit sub
    uProcess.dwSize = sizeOf(uProcess)
    pmc.cb = sizeOf(pmc)
    r = ProcessFirst(hSnapshot, uProcess) 'identification du premier process  
    
    While r <> 0  
        ' puis ouverture des process
        HProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, uProcess.th32ProcessID)
        lret = GetProcessMemoryInfo(HProcess, pmc, pmc.cb) 'état des utilisations mémoire
        ' 'temps de démarrage des process
        GetProcessTimes (HProcess, FT1, FT0, FT0, FT0)
        FileTimeToLocalFileTime (FT1, FT1)
        FileTimeToSystemTime (FT1, ST)  
        ' si les identifiants du process correspondent => garder le nom     
        if uProcess.th32ProcessID = GetCurrentProcessId then curP$ = rTrim$(uProcess.szexeFile) 
        'renvoie des données dans l'affichage  
        ListNomF.AddItems rTrim$(uProcess.szexeFile)
        ListIdF.AddItems str$(uProcess.th32ProcessID) 'Format$("%6.0n", uProcess.th32ProcessID)
        ListMemF.AddItems Format$("%6.0n",pmc.WorkingSetSize / 1024)+"ko"
        ' formatage des temps
        defStr z$,hr$,mn$,sc$,jr$,ms$,an$
        z$ = "0"
        hr$ = Str$(ST.wHour)
        mn$ = Str$(ST.wMinute)
        sc$ = Str$(ST.wSecond)
        jr$ = Str$(ST.wDay)
        ms$ = Str$(ST.wMonth)
        an$ = Str$(ST.wYear)
        if st.wHour<10 then hr$ = z$+hr$
        if st.wMinute<10 then mn$ = z$+mn$
        if st.wSecond<10 then sc$ = z$+sc$
        if st.wDay<10 then jr$ = z$+jr$
        if st.wMonth<10 then ms$ = z$+ms$
                 
        ListTimeF.AddItems "Démarré à " + hr$ + ":" + mn$ + ":" + sc$ + _
                           "  le " + jr$ + "/" + ms$ + "/" + an$
        
        r = ProcessNext(hSnapshot, uProcess) 'process suivant
                                     
    wend     
      
    StatusBar.Panel(0).Caption = str$(listNomF.itemCount)+ " processus en mémoire " 
    'opération d'actualisation de la QListView si ajout ou retrait de process
    if x = 0 then    
        ic = 0   
        actualiser
        x = 1
        ic = ListNomF.itemCount-1
    else
        if ic<>ListNomF.itemCount-1 then  
            actualiser
            x = 0
        end if           
    end if       

    StatusBar.Panel(1).Caption = "Processus courant : " + curP$ '+ ListMemF.item(str$(ListIdF.indexOf(str$(GetCurrentProcessId))))
End sub
'===================================
sub finProcess (sender as QListView) 'termine les process
    if messageBox("Voulez vous vraiment terminer le processus "+listNomF.item(sender.itemIndex)+" ?","Terminer un processus",1) = 1 then   
    dim idp as long
    idP$ = ListIdF.item(sender.itemIndex)

    idp = val(idp$)
    fdwAccess = PROCESS_TERMINATE + PROCESS_QUERY_INFORMATION
    Dim hProcess As Long    
    hProcess = OpenProcess(fdwAccess, 0, idp)

    TerminateProcess (hProcess, 0)
    CloseHandle (hProcess)
    else
        exit sub
    end if     
    Pcanvas.repaint  
end sub
'===================================
sub createP 'utilisation de 2 pointeurs de localisation en mémoire des structures (types API)
    cmdLine$ = pEdit.text
    if cmdLine = "" then showmessage "Spécifier un chemin et un nom de fichier" : exit sub
    siMem.WriteUDT(si)
    piMem.WriteUDT(pi)
    CreateProcess(appName$, cmdLine$, NULL, NULL, 0, 0, NULL, cDir$, siMem.Pointer, piMem.Pointer)

    piMem.Position = 0 'pointeur au début pour relire PROCESS_INFORMATION structure
    piMem.ReadUDT(pi)

    siMem.Close
    piMem.Close  
end sub
'===================================
sub icoProcess(sender as QListView) ' affichage des icones des exe (si présents) 
    Pcanvas.repaint
        fName$ = ListNomF.item(sender.itemIndex)
        icoR = ExtractIcon(application.handle,fName$,0) ' récupération       
         DrawIcon(Pcanvas.handle, 0, 0, icoR )  'affichage dans DC 
         if icoR = 0 then 
             Pcanvas.draw(0,0,icoBitMap.bmp)
             Pcanvas.textout(34,12,"Générique",0,-1)
         end if       
         DestroyIcon (icoR)          
end sub
'===================================
sub actualiser 'rafraichissement de l'affichage des données en cas de modification des listes
    processView.clear
    for i = 0 to ListNomF.itemCount-1
        processView.AddItems listNomF.item(i)
        processView.AddSubItem i, listmemF.item(i)
        processView.AddSubItem i,listIdF.item(i)
        processView.AddSubItem i,listTimeF.item(i)
    next i        
end sub    
'===================================
Form.ShowModal