' 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

CONST NUM_PROCESSES = 1024

CONST NULL = 0

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 ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" (hInst As Long,lpIconPath As long ,byref lpiIcon 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) 'terminer un processus
Declare sub infoProcess(sender as QListView) 'détail sur le processus
Declare sub createP 'lancer un processus

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

Dim icoBitMap as QBitmap
icoBitMap.bmp = "genico.bmp" 

DIM prTimer as QTimer
prTimer.enabled = 1
prTimer.interval = 100
prTimer.onTimer = processList
Dim x as byte
Dim ic as byte
Dim cnt as byte


CREATE Form AS QFORM
    caption = "Gestionnaire des processus de Windows"
    Width = 475
    Height = 540    
    Center
    borderStyle = 3
    onShow = ProcessList
    CREATE pRich as QRichEdit
        left = 210 
        top = 5
        width = 250
        height = 150
        font = pFont
        readOnly = 1
    end create    
    CREATE ListNomF AS QLISTBOX 'stockage info en mémoire
        visible = 0
    END CREATE   
    CREATE ListIdF AS QLISTBOX 'stockage info en mémoire
        visible = 0
    END CREATE    
    CREATE processView as QListView
        left = 5
        top = 5
        width = 195
        height = 480
        font = pFont
        ColumnClick = 0 
        ReadOnly = 1 
        RowSelect = 1 
        Gridlines = 0
        ViewStyle = vsReport
        ShowColumnHeaders = 1
        AddColumns "Processus"',"Id"               
        Column(0).Width = 170
        'Column(1).Width = 80     
        onClick = infoProcess
    END CREATE
    CREATE finBTN as QButton
        caption = "Terminer le processus"
        left = 212
        width = 250
        height = 20
        top = 170      
        onClick =  finProcess 
    END CREATE  
    CREATE Pcanvas AS QCANVAS
        left = 220
        top = 250
        width = 100
        height = 100        
    END CREATE      
    CREATE PButton as QButton
        top = 330
        left = 212
        caption = "Exécuter :"
        onClick = createP 
    END CREATE    
    CREATE pEdit as QEdit
        left = 212         
        top = 360
        width = 250
    END CREATE    
    CREATE StatusBar AS QSTATUSBAR
        AddPanels "",""
        Panel(0).Width = (form.width/2)-10
        Panel(0).Alignment = taCenter  
        Panel(1).Alignment = taCenter  
    END CREATE     
END CREATE


'===================================
sub ProcessList ' listage des processus sans clignotement de la liste      

    listNomF.clear 'rafraichissement des listes
    ListIdF.clear  '
            
    Dim hSnapshot As Long
    Dim g as long  
    Dim r As Long

    hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0) ''capture instantanée des process
    
    If hSnapshot = 0 Then Exit sub 'si planter sortir
    uProcess.dwSize = sizeOf(uProcess) 'déclaré avant le listage
    r = ProcessFirst(hSnapshot, uProcess) 'recherche du premier processus  
    While r <> 0  'boucle de listage
        'ouverture processus 1 par 1
        HProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, uProcess.th32ProcessID)
        'si l'identifiant du process correspond à l'id du process courant le garder
        if uProcess.th32ProcessID = GetCurrentProcessId then curP$ = rTrim$(uProcess.szexeFile)
        ListNomF.AddItems rTrim$(uProcess.szexeFile) 'stocage dans mémoire par listbox
        ListIdF.AddItems str$(uProcess.th32ProcessID) 'idem + calibrage de l'id

        r = ProcessNext(hSnapshot, uProcess) 'process suivant                             
    wend  
    StatusBar.Panel(0).Caption = str$(listNomF.itemCount)+ " processus en mémoire " 
    'renvoie des données dans QlistView pour éviter les rafraichissements permanents
    if x = 0 then    'sauf si modification  de la liste des process
    ic = 0
    processView.clear
    for i = 0 to ListNomF.itemCount-1
        processView.AddItems listNomF.item(i)
    next i    
    x = 1
    ic = ListNomF.itemCount-1
    else
        if ic<>ListNomF.itemCount-1 then 
            processView.clear
            for i = 0 to ListNomF.itemCount-1
                processView.AddItems listNomF.item(i)                             
            next i    
            x = 0
        end if           
    end if        
    StatusBar.Panel(1).Caption = "Processus courant : " + curP$
End sub
'===================================
sub infoProcess(sender as QListView) 'affichages des infos supplémentaires
    Pcanvas.repaint
    pRich.clear
    dim idp as long
    idP$ = ListIdF.item(sender.itemIndex) 'id du process
    idp = val(idp$)
        'info sur l'occupation mémoire
        pmc.cb = sizeOf(pmc)
        HProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, idp)
        lret = GetProcessMemoryInfo(HProcess, pmc, pmc.cb)
        'récupération des info de temps et formatage 
        GetProcessTimes (HProcess, FT1, FT0, FT0, FT0)
        FileTimeToLocalFileTime (FT1, FT1)
        FileTimeToSystemTime (FT1, ST)  
        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$
        '
        if pmc.WorkingSetSize < 1024 then 
            oct = 1 
            oct$ = "o"
        else 
            oct = 1024
            oct$ = "ko"
        end if
        fName$ = ListNomF.item(sender.itemIndex)
        icoR = ExtractIcon(application.handle,fName$,0) 'extraction de l'icone éventuel de l'exe
        size$ = strf$((pmc.WorkingSetSize / 1024),ffNumber,8,0)+oct$
        'affichage info
        pRich.Text = ListNomF.item(sender.itemIndex)+ chr$(13) + chr$(13) + _
                    "id = " + idp$ + chr$(13) + chr$(13) + _
                    "Utilisation mémoire = "+ size$ + chr$(13) + chr$(13) + _
                    "Démarré à " + hr$ + ":" + mn$ + ":" + sc$ + "  le " + jr$ + "/" + ms$ + "/" + an$        
         DrawIcon(Pcanvas.handle, 0, 0, icoR ) 'icone dans QCanvas  
         if icoR = 0 then ' si pas d'icone ...
             Pcanvas.draw(0,0,icoBitMap.bmp)
             Pcanvas.textout(0,33,"Générique",0,-1)
         end if       
         DestroyIcon (icoR) 'vider la mémoire de l'ancien             
end sub        
'===================================
sub finProcess (sender as QListView) 'opération de suppression 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)
    'fin et sortie
    TerminateProcess (hProcess, 0)
    CloseHandle (hProcess)
    else
        exit sub
    end if       
end sub
'===================================
sub createP 'créer un process (pointeur structures en mémoire cause type se suive pas en RQ)
    cmdLine$ = pEdit.text
    if cmdLine = "" then showmessage "Spécifier un chemin et un nom de fichier" : exit sub
    siMem.WriteUDT(si) 'UDT du type mémorisé
    piMem.WriteUDT(pi) 'UDT du type mémorisé
    'ouverture de l'appli spécifié dans l'éditeur selon la localisation en mémoire
    CreateProcess(appName$, cmdLine$, NULL, NULL, 0, 0, NULL, cDir$, siMem.Pointer, piMem.Pointer)
    ' 
    piMem.Position = 0 
    piMem.ReadUDT(pi)

    siMem.Close
    piMem.Close    
end sub
'===================================


Form.ShowModal