Título: Listar procesos, threads, módulos y ventanas. Publicado por: Slasher-K en 9 Junio 2005, 09:13 am Bueno lo siguiente es un código que escribi hace mucho y que lista todos los procesos del sistema, cos sus threads, módulos atados y las ventanas de cada thread. Se puede utilizar para hacer un árbol de recursos o algo similar.
También tiene un sistema que loguea los procesos creando una tabla en memoria con los datos de todos los procesos y luego se puede guardar en un archivo. El código es algo complejo pero no tengo ganas de ponerle los comentarios xDDD. Con sólo llamar a EnumProcesses la variable global SysProcess va a tener almacenados todos los procesos y sus datos. Código: '***************************************************************** ' 'Autor: Slasher Keeper 'Descripción: ' * Lista procesos del sistema y sus recursos. ' * Loguea los procesos. '***************************************************************** ' Option Explicit Option Base 1 Public Const MAX_PATH = 260 Const TH32CS_SNAPHEAPLIST = &H1 Const TH32CS_SNAPPROCESS = &H2 Const TH32CS_SNAPTHREAD = &H4 Const TH32CS_SNAPMODULE = &H8 Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE) Type WindowInfo ProcessId As Long ThreadID As Long NumThdWindows As Long ThreadWindows() As Long hwndParent As Long hwnd As Long hModule As Long hIcon As Long Identifier As Long WindowProc As Long hInstance As Long Style As Long UserData As Long ChildWindows() As Long NumOfChild As Integer Index As Integer ClassName As String Text As String * MAX_PATH ModuleName As String * MAX_PATH End Type Type ThreadInfo ThreadID As Long BasePriority As Long UsageCount As Long AttachCount As Long End Type Type ModuleInfo BaseAddress As Long hModule As Long ModuleSize As Long ProcessId As Long ModuleId As Long GlobalUsage As Long ProcessUsage As Long Filename As String * MAX_PATH ModuleName As String * MAX_PATH End Type Type ProcessInfo hProcess As Long ProcessId As Long ParentProcessID As Long PriorityClass As Long MinWorkingSetSize As Long MaxWorkingSetSize As Long ExitCode As Long AffinityMask As Long SysAffinityMask As Long HandleCount As Long NumOfThreads As Long NumOfModules As Long CurrentMemPage As Long Threads() As ThreadInfo Modules() As ModuleInfo ExeFilename As String * MAX_PATH Index As Integer End Type Type FileVersionInfo CompanyName As String FileDescription As String FileVersion As String InternalName As String LegalCopyright As String OriginalFileName As String ProductName As String ProductVersion As String Comments As String FileOS As String End Type Type HEAPENTRY32 dwSize As Long hHandle As Long dwAddress As Long dwBlockSize As Long dwFlags As Long dwLockCount As Long dwResvd As Long th32ProcessID As Long th32HeapID As Long End Type Type Var wLength As Integer wValueLength As Integer wType As Integer szKey As Long Padding As Long Value() As Long End Type Type MODULEENTRY32 dwSize As Long th32ModuleID As Long th32ProcessID As Long GlblcntUsage As Long ProccntUsage As Long modBaseAddr As Long modBaseSize As Long hModule As Long szModule As String * 256 szExePath As String * 256 End Type 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 Type THREADENTRY32 dwSize As Long cntUsage As Long th32ThreadID As Long th32OwnerProcessID As Long tpBasePri As Long tpDeltaPri As Long dwFlags As Long End Type Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long Declare Function Heap32First Lib "kernel32" (lpHE As HEAPENTRY32, ByVal th32ProcessID As Long, ByVal th32HeapID As Long) As Boolean Declare Function Heap32ListFirst Lib "kernel32" (ByVal hSnapshot As Long, lphl As HEAPENTRY32) As Boolean Declare Function Heap32ListNext Lib "kernel32" (ByVal hSnapshot As Long, lphl As HEAPENTRY32) As Boolean Declare Function Heap32Next Lib "kernel32" (lpHE As HEAPENTRY32) As Boolean Declare Function Module32First Lib "kernel32" (ByVal hSnapshot As Long, lpME As MODULEENTRY32) As Boolean Declare Function Module32Next Lib "kernel32" (ByVal hSnapshot As Long, lpME As MODULEENTRY32) As Boolean Declare Function Process32First Lib "kernel32" (ByVal hSnapshot As Long, lpPE As PROCESSENTRY32) As Boolean Declare Function Process32Next Lib "kernel32" (ByVal hSnapshot As Long, lpPE As PROCESSENTRY32) As Boolean Declare Function Thread32First Lib "kernel32" (ByVal hSnapshot As Long, lpte As THREADENTRY32) As Boolean Declare Function Thread32Next Lib "kernel32" (ByVal hSnapshot As Long, lpte As THREADENTRY32) As Boolean Declare Function Toolhelp32ReadProcessMemory Lib "kernel32" (ByVal th32ProcessID As Long, lpBaseAddress As Any, lpBuffer As Any, ByVal cbRead As Long, lpNumberOfBytesRead As Long) As Boolean Declare Function GetCurrentThread Lib "kernel32" () As Long 'Devuelve una pseudo-referencia al subproceso actual. Declare Function GetCurrentThreadId Lib "kernel32" () As Long 'Devuelve el identificador de subproceso del subproceso que llama a la función. Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lpExitCode As Long) As Long 'Devuelve el estado de terminación del subproceso actual. Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long 'Devuelve la clase de prioridad para el proceso especificado. Declare Function GetProcessAffinityMask Lib "kernel32" (ByVal hProcess As Long, lpProcessAffinityMask As Long, SystemAffinityMask As Long) As Long 'Devuelve la máscara de afinidad (valor que indica sobre qué procesador se puede ejecutar) para el proceso especificado. Declare Function GetProcessShutdownParameters Lib "kernel32" (lpdwLevel As Long, lpdwFlags As Long) As Long 'Devuelve los parámetros de cierre para el proceso que llama a la función. Declare Function GetProcessWorkingSetSize Lib "kernel32" (ByVal hProcess As Long, lpMinimumWorkingSetSize As Long, lpMaximumWorkingSetSize As Long) As Long 'Obtiene el mínimo y el máximo del tamaño del espacio de trabajo (working set) de un proceso especificado. Declare Function GetThreadPriority Lib "kernel32" (ByVal hThread As Long) As Long 'Devuelve el nivel de prioridad para el subproceso especificado. Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long 'Establece la clase de prioridad para el proceso especificado. Declare Function WriteProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, Optional lpNumberOfBytesWritten As Long) As Long Declare Function ReadProcessMemory Lib "kernel32" (ByVal hProcess As Long, ByVal lpBaseAddress As Long, lpBuffer As Any, ByVal nSize As Long, Optional lpNumberOfBytesWritten As Long) As Long Declare Function GetWindowModuleFileName Lib "user32" Alias "GetWindowModuleFileNameA" (ByVal hwnd As Long, ByVal lpszFileName As String, ByVal cchFileNameMax As Long) As Long Declare Function EnumThreadWindows Lib "user32" (ByVal dwThreadId As Long, ByVal lpfn As Long, lParam As WindowInfo) As Long Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long Public SysProcess() As ProcessInfo Public SysModule() As ModuleInfo Public Windows() As WindowInfo Public lSysProcCnt As Long Public lSysModCnt As Long Public lWinCnt As Long Private CancelProcessLog As Boolean Private bIsLogging As Boolean Private bProcLogStarted As Boolean Private hProcTable As Long Property Get ActiveProcessId() As Long Dim r& r = GetWindowThreadProcessId(GetForegroundWindow, ActiveProcessId) End Property Property Get ActiveProcess() As ProcessInfo ActiveProcess = GetProcessInfoById(ActiveProcessId) End Property Property Get ActiveThreadId() As Long ActiveThreadId = GetWindowThreadProcessId(GetForegroundWindow, 0) End Property Property Get IsProcessLogEnabled() As Boolean IsProcessLogEnabled = bIsLogging End Property Sub EnumProcesses(Optional OpenHandles As Boolean = False) Dim hSnap& Dim pe32 As PROCESSENTRY32 Erase SysProcess lSysProcCnt = 0 'Crea el objeto Snapshot. hSnap& = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&) pe32.dwSize = LenB(pe32) 'Obtiene el primer proceso. If Process32First(hSnap, pe32) Then lSysProcCnt = 1 ReDim SysProcess(lSysProcCnt) As ProcessInfo SysProcess(lSysProcCnt) = GetProcessInfo(pe32, OpenHandles) SysProcess(lSysProcCnt).Index = lSysProcCnt Do While Process32Next(hSnap, pe32) lSysProcCnt = lSysProcCnt + 1 ReDim Preserve SysProcess(lSysProcCnt) As ProcessInfo SysProcess(lSysProcCnt) = GetProcessInfo(pe32, OpenHandles) SysProcess(lSysProcCnt).Index = lSysProcCnt Loop End If Call CloseHandle(hSnap) End Sub Function GetWindowInfo(ByVal hwnd As Long, Optional EnumThdWins As Boolean = True) As WindowInfo On Error Resume Next Dim r& With GetWindowInfo .hwnd = hwnd .hwndParent = GetParent(hwnd) .ThreadID = GetWindowThreadProcessId(hwnd, .ProcessId) .hIcon = GetClassLong(.hwndParent, GCL_HICON) .hInstance = GetWindowLong(.hwndParent, GWL_HINSTANCE) .Identifier = GetWindowLong(.hwndParent, GWL_ID) .Style = GetWindowLong(.hwndParent, GWL_STYLE) .WindowProc = GetWindowLong(.hwndParent, GWL_WNDPROC) .UserData = GetWindowLong(.hwndParent, GWL_USERDATA) r = EnumChildWindows(hwnd, AddressOf EnumChildProc, GetWindowInfo) .ClassName = String$(256, 0) r = GetClassName(hwnd, .ClassName, MAX_PATH) .ClassName = Left$(.ClassName, r) .Text = GetWindowText(hwnd) r = GetWindowModuleFileName(hwnd, .ModuleName, MAX_PATH) .ModuleName = Left$(.ModuleName, r) .hModule = GetModuleHandle(Trim(.ModuleName)) If EnumThdWins Then _ r = EnumThreadWindows(.ThreadID, AddressOf EnumThreadWndProc, GetWindowInfo) End With End Function Function GetProcessInfo(pProcess As PROCESSENTRY32, Optional OpenHandle As Boolean = False) As ProcessInfo 'Obtiene información acerca de un proceso. ' With GetProcessInfo .hProcess = OpenProcess(PROCESS_ALL_ACCESS, False, pProcess.th32ProcessID) .ProcessId = pProcess.th32ProcessID .ParentProcessID = pProcess.th32ParentProcessID .PriorityClass = GetPriorityClass(.hProcess) .NumOfThreads = pProcess.cntThreads .Threads = EnumThreads(.ProcessId) .Modules = EnumModules(.ProcessId, .NumOfModules) .ExeFilename = RTrim$(pProcess.szExeFile) .HandleCount = pProcess.cntUsage Call GetProcessWorkingSetSize(.hProcess, .MinWorkingSetSize, .MaxWorkingSetSize) Call GetExitCodeProcess(.hProcess, .ExitCode) Call GetProcessAffinityMask(.hProcess, .AffinityMask, .SysAffinityMask) If Not OpenHandle Then 'Se cierra el controlador del proceso. ' Call CloseHandle(.hProcess) .hProcess = 0 End If End With End Function Function EnumThreads(ByVal ProcessId As Long) As ThreadInfo() Dim te32 As THREADENTRY32 Dim thds() As ThreadInfo Dim iCount% Dim hSnap& 'Crea el objeto snapshot. hSnap& = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&) te32.dwSize = LenB(te32) If Thread32First(hSnap, te32) Then 'Si se obtiene el primer subproceso. If te32.th32OwnerProcessID = ProcessId Then GoSub GetThreadInfo Do While Thread32Next(hSnap, te32) 'Obtiene los siguientes subprocesos y verifica 'que pertenezcan al proceso especificado. If te32.th32OwnerProcessID = ProcessId Then GoSub GetThreadInfo End If Loop End If CloseHandle hSnap EnumThreads = thds Exit Function GetThreadInfo: iCount = iCount + 1 ReDim Preserve thds(iCount) As ThreadInfo With thds(iCount) .ThreadID = te32.th32ThreadID .BasePriority = te32.tpBasePri .UsageCount = te32.cntUsage End With Return End Function Function EnumModules(Optional ByVal ProcessId As Long, Optional NumOfModules As Long) As ModuleInfo() Dim me32 As MODULEENTRY32 Dim pModule() As ModuleInfo Dim iCount% Dim hSnap& If ProcessId = 0 Then ProcessId = GetCurrentProcessId 'Crea el objeto snapshot. hSnap& = CreateToolhelp32Snapshot(TH32CS_SNAPALL, ProcessId) me32.dwSize = LenB(me32) If Module32First(hSnap, me32) Then 'Si se obtiene el primer módulo. GoSub GetModuleInfo Do While Module32Next(hSnap, me32) 'Obtiene los siguientes módulos. If me32.th32ProcessID = ProcessId Then GoSub GetModuleInfo End If Loop End If CloseHandle hSnap NumOfModules = iCount EnumModules = pModule Exit Function GetModuleInfo: iCount = iCount + 1 ReDim Preserve pModule(iCount) As ModuleInfo With pModule(iCount) .hModule = me32.hModule .ModuleId = me32.th32ModuleID .BaseAddress = me32.modBaseAddr .ModuleSize = me32.modBaseSize .GlobalUsage = me32.GlblcntUsage .ProcessUsage = me32.ProccntUsage .ProcessId = ProcessId .ModuleName = Left$(me32.szModule, InStr(1, me32.szModule, vbNullChar) - 1) .Filename = Left$(me32.szExePath, InStr(1, me32.szExePath, vbNullChar) - 1) End With Return End Function Function EnumSysModules() As Long On Error Resume Next Dim i&, ind& Call EnumProcesses Erase SysModule lSysModCnt = 0 For i = 1 To lSysProcCnt For ind = 1 To SysProcess(i).NumOfModules If Not ModuleExist(SysProcess(i).Modules(ind)) Then lSysModCnt = lSysModCnt + 1 ReDim Preserve SysModule(lSysModCnt) As ModuleInfo SysModule(lSysModCnt) = SysProcess(i).Modules(ind) End If Next Next EnumSysModules = lSysModCnt End Function Function EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Boolean Dim pWin As WindowInfo pWin = GetWindowInfo(hwnd, False) lWinCnt = lWinCnt + 1 ReDim Preserve Windows(lWinCnt) As WindowInfo pWin.Index = lWinCnt Windows(lWinCnt) = pWin EnumWindowsProc = True End Function Function EnumChildProc(ByVal hwnd As Long, lParam As WindowInfo) As Boolean With lParam .NumOfChild = .NumOfChild + 1 ReDim Preserve .ChildWindows(.NumOfChild) .ChildWindows(.NumOfChild) = hwnd End With EnumChildProc = True End Function Function EnumThreadWndProc(ByVal hwnd As Long, lParam As WindowInfo) As Boolean With lParam .NumThdWindows = .NumThdWindows + 1 ReDim Preserve .ThreadWindows(.NumThdWindows) As Long .ThreadWindows(.NumThdWindows) = hwnd EnumThreadWndProc = True End With End Function Function KillProcessByName(AppExeFilename As String, Optional Wait As Boolean = False, Optional WaitTime As Long, Optional KillAll As Boolean = False) As Boolean Dim sAppName$ Dim i% Call EnumProcesses For i = 1 To lSysProcCnt sAppName = RTrim$(Replace(GetFileTitle(SysProcess(i).ExeFilename), vbNullChar, vbNullString)) If InStr(1, sAppName, AppExeFilename, vbTextCompare) Then If SysProcess(i).ProcessId = GetCurrentProcessId Then Exit Function KillProcessByName = KillProcessById(SysProcess(i).ProcessId, Wait, WaitTime) If Not KillAll Then Exit For End If End If Next End Function Function KillProcessById(ProcessId As Long, Optional Wait As Boolean = False, Optional WaitTime As Long) As Boolean Dim hProcess&, r& If ProcessId = GetCurrentProcessId Then Exit Function hProcess = OpenProcess(PROCESS_ALL_ACCESS, False, ProcessId) If hProcess Then KillProcessById = (TerminateProcess(hProcess, 0)) If Wait Then If WaitTime = 0 Then WaitTime = 3000 r = WaitForSingleObject(hProcess, WaitTime) If r <> WAIT_OBJECT_0 Then KillProcessById = False End If End If r = CloseHandle(hProcess) End If End Function Function GetProcessInfoById(ProcessId As Long) As ProcessInfo Dim pProcess As ProcessInfo Dim i& Call EnumProcesses For i = 1 To lSysProcCnt If SysProcess(i).ProcessId = ProcessId Then GetProcessInfoById = SysProcess(i) Exit For End If Next End Function Private Function ModuleExist(pModuleInfo As ModuleInfo) As Boolean On Error Resume Next Dim i& For i = 1 To lSysModCnt If (pModuleInfo.Filename Like SysModule(i).Filename) And _ pModuleInfo.ModuleId = SysModule(i).ModuleId Then ModuleExist = True Exit For End If Next End Function Sub ProcLogTmrProc(ByVal hwnd As Long, ByVal uMsg As Integer, ByVal idEvent As Integer, ByVal dwTime As Long) Dim r& r = KillTimer(0&, idEvent) bProcLogStarted = True Call StartProcessLog End Sub Function StartProcessLog() As Long 'Devuelve un puntero a memoria en donde se encuentran 'almacenados una serie de estructuras ProcessInfo 'que identifican a los procesos. 'Estas estructuras comienzan 4 (cuatro) bytes más 'adelante que dicho puntero. Esto cuatro bytes 'es un valor de tipo Long que indica la cantidad 'de estructuras que existen en la tabla. On Error Resume Next Dim pProcessInfo As ProcessInfo Dim pProcess() As ProcessInfo Dim lProcCnt& Dim snTime! Dim i&, r& If Not bProcLogStarted Then r = SetTimer(0&, 0&, 0&, AddressOf ProcLogTmrProc) Exit Function End If Call EnumProcesses Call ProcTableInitialize snTime = Timer Do While Not CancelProcessLog If (Timer - snTime) > 2 Then Call EnumProcesses snTime = Timer End If If lSysProcCnt <> lProcCnt Then 'Terminó o se creó un proceso. ' If lProcCnt < lSysProcCnt Then 'Fue creado un nuevo proceso. ' For i = lProcCnt + 1 To lSysProcCnt Call ProcTableAddEntry(SysProcess(i)) If i Mod 4 = 0 Then DoEvents Next pProcess = SysProcess lProcCnt = lSysProcCnt Else 'Si terminó un proceso 'busca el proceso que terminó. ' End If pProcess = SysProcess lProcCnt = lSysProcCnt End If DoEvents Loop StartProcessLog = hProcTable CancelProcessLog = False bProcLogStarted = False Call ProcTableRelease End Function Sub EndProcessLog() CancelProcessLog = True End Sub Function ProcTableAddEntry(pInfo As ProcessInfo) As Boolean Dim lOffset&, r&, i& Dim dtNow As Date If ProcTableGetEntryCount >= 32767 Then Exit Function 'Actualiza la tabla de módulos. ' Call ProcTableRefreshModuleTable '16 bytes: 8 bytes to start time, 8 bytes to end time lOffset = ProcTableCalculateOffset(ProcTableGetEntryCount + 1) r = WriteProcessMemory(GetCurrentProcess(), lOffset, GetProcessInfoSize(pInfo), 4) lOffset = lOffset + 4 r = WriteProcessMemory(GetCurrentProcess(), lOffset, pInfo, 52) lOffset = lOffset + 52 For i = 1 To pInfo.NumOfThreads r = WriteProcessMemory(GetCurrentProcess(), lOffset, pInfo.Threads(i), Len(pInfo.Threads(i))) lOffset = lOffset + Len(pInfo.Threads(i)) Next r = WriteProcessMemory(GetCurrentProcess(), lOffset, ProcTableGetIndexes(pInfo)(1), 4 * pInfo.NumOfModules) lOffset = lOffset + (4 * pInfo.NumOfModules) r = WriteProcessMemory(GetCurrentProcess(), lOffset, CInt(Len(RTrim$(Replace$(pInfo.ExeFilename, vbNullChar, vbNullString)))), 2&) lOffset = lOffset + 2 r = WriteProcessMemory(GetCurrentProcess(), lOffset, ByVal pInfo.ExeFilename, Len(RTrim$(Replace$(pInfo.ExeFilename, vbNullChar, vbNullString)))) lOffset = lOffset + Len(RTrim$(Replace$(pInfo.ExeFilename, vbNullChar, vbNullString))) dtNow = Now r = WriteProcessMemory(GetCurrentProcess(), lOffset, dtNow, 8) r = WriteProcessMemory(GetCurrentProcess(), lOffset + 8, dtNow, 8) If r Then r = WriteProcessMemory(GetCurrentProcess(), hProcTable, ProcTableGetEntryCount() + 1, 2) End If ProcTableAddEntry = (r <> 0) End Function Function ProcTableGetEntry(Index As Integer) As ProcessInfo Dim lOffset&, r&, i& Dim pEntry As ProcessInfo Dim iSize%, iModSize% If (Index < 0 Or Index > ProcTableGetEntryCount()) Or hProcTable = 0 Then Exit Function lOffset = ProcTableCalculateOffset(Index) r = ReadProcessMemory(GetCurrentProcess(), lOffset + 4, pEntry, 52) lOffset = lOffset + 4 + 52 ReDim pEntry.Threads(1 To pEntry.NumOfThreads) As ThreadInfo r = ReadProcessMemory(GetCurrentProcess(), lOffset, pEntry.Threads(1), Len(pEntry.Threads(1)) * pEntry.NumOfThreads) lOffset = lOffset + (Len(pEntry.Threads(1)) * pEntry.NumOfThreads) ReDim pEntry.Modules(1 To pEntry.NumOfModules) As ModuleInfo For i = 1 To pEntry.NumOfModules r = ReadProcessMemory(GetCurrentProcess(), lOffset, pEntry.Modules(i), 28) lOffset = lOffset + 28 r = ReadProcessMemory(GetCurrentProcess(), lOffset, iSize, 2&) lOffset = lOffset + 2 r = ReadProcessMemory(GetCurrentProcess(), lOffset, ByVal pEntry.Modules(i).Filename, iSize) lOffset = lOffset + iSize r = ReadProcessMemory(GetCurrentProcess(), lOffset, iSize, 2&) lOffset = lOffset + 2 r = ReadProcessMemory(GetCurrentProcess(), lOffset, ByVal pEntry.Modules(i).ModuleName, iSize) lOffset = lOffset + iSize Next r = ReadProcessMemory(GetCurrentProcess(), lOffset, iSize, 2) lOffset = lOffset + 2 r = ReadProcessMemory(GetCurrentProcess(), lOffset, ByVal pEntry.ExeFilename, iSize) ProcTableGetEntry = pEntry End Function Function ProcTableGetEntryCount() As Integer Dim iCnt% If hProcTable Then Call ReadProcessMemory(GetCurrentProcess(), hProcTable, iCnt, 2) ProcTableGetEntryCount = iCnt End If End Function Function ProcTableFindEntry(ProcessId As Long, Optional outIndex As Integer) As ProcessInfo Dim pProcess As ProcessInfo Dim i% For i = 1 To ProcTableGetEntryCount() pProcess = ProcTableGetEntry(i) If pProcess.ProcessId = ProcessId Then ProcTableFindEntry = pProcess outIndex = i Exit For End If Next End Function Function ProcTableNotifyEnd(ProcessId As Long) As Boolean Dim dtEndTime As Date Dim pProcess As ProcessInfo Dim iIndex%, lOffset& Dim r& pProcess = ProcTableFindEntry(ProcessId, iIndex) lOffset = ProcTableGetOffset(pProcess) + ProcTableGetEntrySize(iIndex) - 8 dtEndTime = Now r = WriteProcessMemory(GetCurrentProcess(), lOffset, dtEndTime, 8) End Function Function ProcTableCalculateOffset(Index As Integer) As Long Dim lOffset& Dim pProcInfo As ProcessInfo Dim pThdInfo As ThreadInfo Dim pModInfo As ModuleInfo Dim i%, r& Dim lSize& lOffset = GetProcTableOffset For i = 1 To ProcTableGetEntryCount() lOffset = lOffset + lSize r = ReadProcessMemory(GetCurrentProcess(), hProcTable + lOffset, lSize, 4) If i = Index Then Exit For Next lOffset = hProcTable + lOffset ProcTableCalculateOffset = lOffset End Function Function ProcTableGetOffset(ProcessInfo As ProcessInfo) As Long Dim pProcInfo As ProcessInfo, i% For i = 1 To ProcTableGetEntryCount() pProcInfo = ProcTableGetEntry(i) If pProcInfo.ProcessId = ProcessInfo.ProcessId Then 'Se encontró el proceso en la tabla. ' ProcTableGetOffset = ProcTableCalculateOffset(i) Exit For End If Next End Function Function ProcTableGetEntrySize(Index As Integer) As Long Dim lOffset&, lSize& Dim r& lOffset = ProcTableCalculateOffset(Index) r = ReadProcessMemory(GetCurrentProcess(), lOffset, lSize, 4) ProcTableGetEntrySize = lSize End Function Function GetProcessInfoSize(ProcInfo As ProcessInfo) As Long Dim pThdInfo As ThreadInfo Dim pModInfo As ModuleInfo Dim lSize&, i& lSize = 52 + (Len(pThdInfo) * ProcInfo.NumOfThreads) + 16 + 4 lSize = lSize + ProcInfo.NumOfModules * 4 'Tabla de indices de modulos. lSize = lSize + Len(RTrim$(Replace$(ProcInfo.ExeFilename, vbNullChar, vbNullString))) lSize = lSize + 2 GetProcessInfoSize = lSize End Function Function ProcTableSaveToFile(Filename As String, Optional AppendData As Boolean = True) As Boolean Dim hFile&, sMagic$ Dim lOffset&, lTableSize& Dim sData$, lDataSize& Dim r& hFile = CreateFile(Filename, GENERIC_READ Or GENERIC_WRITE, 1&, 0&, OPEN_ALWAYS, 0&, 0&) If hFile = INVALID_HANDLE_VALUE Then Exit Function sMagic = String$(3, 0) r = ReadFileStr(hFile, ByVal sMagic, 3&, 0&, ByVal 0&) If AppendData And StrComp(sMagic, "DAT") = False Then lOffset = GetFileSize(hFile, 0) + 1 ElseIf Not AppendData Or StrComp(sMagic, "DAT") Then r = CloseHandle(hFile) r = DeleteFile(Filename) hFile = CreateFile(Filename, GENERIC_READ Or GENERIC_WRITE, 1&, 0&, CREATE_ALWAYS, 0&, 0&) r = WriteFileStr(hFile, ByVal "DAT", 3&, 0&, ByVal 0&) lOffset = 21 End If lTableSize = ProcTableGetTableSize() lDataSize = GetModuleTableSize + lTableSize + 1 r = SetFilePointer(hFile, 3, 0, FILE_BEGIN) r = WriteFile(hFile, ByVal hProcTable, 10, 0&, ByVal 0&) r = WriteFile(hFile, 1, 1, 0&, ByVal 0&) 'Formato del archivo. r = WriteFile(hFile, 1, 1, 0&, ByVal 0&) 'cifrado. r = WriteFile(hFile, lDataSize, 4, 0&, ByVal 0&) 'Longitud de los datos no cifrados. r = SetFilePointer(hFile, lOffset, 0, FILE_BEGIN) sData = String$(lDataSize, 0) r = ReadProcessMemory(GetCurrentProcess(), hProcTable + 10, ByVal sData, Len(sData)) r = WriteFile(hFile, Len(sData), 4, 0&, ByVal 0&) 'Longitud de los datos cifrados. r = WriteFileStr(hFile, ByVal sData, Len(sData), 0&, ByVal 0&) 'Datos cifrados. r = CloseHandle(hFile) End Function Function ProcTableGetTableSize() As Long Dim lSize&, i% For i = 1 To ProcTableGetEntryCount() lSize = lSize + ProcTableGetEntrySize(i) Next ProcTableGetTableSize = lSize End Function Function GetModInfoSize(pInfo As ModuleInfo) As Long Dim lSize& With pInfo lSize = 28 lSize = lSize + Len(RTrim$(Replace$(.Filename, vbNullChar, vbNullString))) lSize = lSize + Len(RTrim$(Replace$(.ModuleName, vbNullChar, vbNullString))) GetModInfoSize = lSize End With End Function Function GetProcTableOffset() As Long Dim lSize& Dim r& r = ReadProcessMemory(GetCurrentProcess(), hProcTable + 6, lSize, 4) GetProcTableOffset = lSize + 10 End Function Function GetProcTableOffsetRVA() As Long Dim lSize& lSize = hProcTable + GetProcTableOffset GetProcTableOffsetRVA = lSize End Function Function ProcTableGetModuleCount() As Long Dim lCnt&, r& r = ReadProcessMemory(GetCurrentProcess(), hProcTable + 2, lCnt, 4) ProcTableGetModuleCount = lCnt End Function Function ProcTableGetModuleOffset(Index As Long) As Long Dim lOffset&, i&, r& Dim lSize& lOffset = 10 For i = 1 To ProcTableGetModuleCount lOffset = lOffset + lSize r = ReadProcessMemory(GetCurrentProcess(), hProcTable + lOffset, lSize, 4&) If Index = i Then ProcTableGetModuleOffset = hProcTable + lOffset Exit For End If Next End Function Function ProcTableGetModuleInfo(Index As Long) As ModuleInfo Dim pModule As ModuleInfo Dim lOffset&, i&, r& Dim iSize% lOffset = ProcTableGetModuleOffset(Index) + 4 r = ReadProcessMemory(GetCurrentProcess(), lOffset, pModule, 28) lOffset = lOffset + 28 r = ReadProcessMemory(GetCurrentProcess(), lOffset, iSize, 2) lOffset = lOffset + 2 If iSize > MAX_PATH Then iSize = MAX_PATH r = ReadProcessMemory(GetCurrentProcess(), lOffset, ByVal pModule.Filename, iSize) lOffset = lOffset + iSize r = ReadProcessMemory(GetCurrentProcess(), lOffset, iSize, 2) If iSize > MAX_PATH Then iSize = MAX_PATH lOffset = lOffset + 2 r = ReadProcessMemory(GetCurrentProcess(), lOffset, ByVal pModule.ModuleName, iSize) ProcTableGetModuleInfo = pModule End Function Function ProcTableGetModuleIndex(ModuleId As Long) As Long Dim pModule As ModuleInfo Dim i& For i = 1 To ProcTableGetModuleCount pModule = ProcTableGetModuleInfo(i) If pModule.ModuleId = ModuleId Then ProcTableGetModuleIndex = i Exit For End If Next End Function Function ProcTableGetIndexes(ProcInfo As ProcessInfo) As Long() Dim pModule As ModuleInfo Dim lIndex&(), lCnt& Dim i&, ind% For i = 1 To ProcTableGetModuleCount pModule = ProcTableGetModuleInfo(i) For ind = 1 To ProcInfo.NumOfModules If pModule.ModuleId = ProcInfo.Modules(ind).ModuleId Then lCnt = lCnt + 1 ReDim Preserve lIndex&(lCnt) lIndex&(lCnt) = i Exit For End If Next Next ProcTableGetIndexes = lIndex End Function Function GetModuleTableSize() As Long Dim lSize&, r& r = ReadProcessMemory(GetCurrentProcess(), hProcTable + 6, lSize, 4) GetModuleTableSize = lSize End Function Sub ProcTableInitialize() If hProcTable = 0 Then 'Asigna memoria para 32767 entradas en la tabla, aprox.. ' hProcTable = VirtualAlloc(0&, 10551296 + 2&, MEM_COMMIT, PAGE_READWRITE) Call ProcTableInitModuleTable End If End Sub Sub ProcTableRelease(Optional Force As Boolean = False) Dim r& If hProcTable Then r = VirtualFree(hProcTable, 0&, MEM_RELEASE) If r Or Force Then hProcTable = 0 End If End If End Sub Sub ProcTableInitModuleTable() Dim lOffset&, i& Dim lTableSize& Dim r& Call EnumSysModules lOffset = hProcTable + 10 For i = 1 To lSysModCnt r = WriteProcessMemory(GetCurrentProcess(), lOffset, GetModInfoSize(SysModule(i)) + 4 + 4, 4) lOffset = lOffset + 4 r = WriteProcessMemory(GetCurrentProcess(), lOffset, SysModule(i), 28) lOffset = lOffset + 28 r = WriteProcessMemory(GetCurrentProcess(), lOffset, Len(RTrim$(Replace$(SysModule(i).Filename, vbNullChar, vbNullString))), 2) lOffset = lOffset + 2 r = WriteProcessMemory(GetCurrentProcess(), lOffset, ByVal SysModule(i).Filename, Len(RTrim$(Replace$(SysModule(i).Filename, vbNullChar, vbNullString)))) lOffset = lOffset + Len(RTrim$(Replace$(SysModule(i).Filename, vbNullChar, vbNullString))) r = WriteProcessMemory(GetCurrentProcess(), lOffset, Len(RTrim$(Replace$(SysModule(i).ModuleName, vbNullChar, vbNullString))), 2) lOffset = lOffset + 2 r = WriteProcessMemory(GetCurrentProcess(), lOffset, ByVal SysModule(i).ModuleName, Len(RTrim$(Replace$(SysModule(i).ModuleName, vbNullChar, vbNullString)))) lOffset = lOffset + Len(RTrim$(Replace$(SysModule(i).ModuleName, vbNullChar, vbNullString))) lTableSize = lTableSize + GetModInfoSize(SysModule(i)) + 4 + 2 + 2 Next r = WriteProcessMemory(GetCurrentProcess(), hProcTable + 2, lSysModCnt, 4) r = WriteProcessMemory(GetCurrentProcess(), hProcTable + 6, lTableSize, 4) End Sub Sub ProcTableRefreshModuleTable() Dim hTmp&, lSize&, r& lSize = ProcTableGetTableSize hTmp = VirtualAlloc(0&, lSize, MEM_COMMIT, PAGE_READWRITE) If hTmp Then r = ReadProcessMemory(GetCurrentProcess(), GetProcTableOffsetRVA, _ ByVal hTmp, lSize) If r Then Call ProcTableInitModuleTable r = ReadProcessMemory(GetCurrentProcess(), hTmp, _ ByVal GetProcTableOffsetRVA, lSize) End If r = VirtualFree(hTmp, 0, MEM_RELEASE) End If End Sub Function GetVersionInfo(Filename As String) As FileVersionInfo Dim pFixedInfo As VS_FIXEDFILEINFO Dim pFileInfo As FileVersionInfo Dim sCharset$, btCharset(4) As Byte Dim lCharset&, hCharBlck& Dim lInfoSize&, hVersion& Dim sVerData$, sVerBlck$, lLen& Dim sVerInfo$(9), sData$, i%, r& Dim lBinType& lInfoSize = GetFileVersionInfoSize(Filename, 0&) sVerData$ = String$(lInfoSize, 0) r = GetFileVersionInfo(Filename, 0&, lInfoSize, sVerData) If r = 0 Then Exit Function r = VerQueryValue(sVerData, "\VarFileInfo\Translation", hCharBlck, lLen) If r = 0 Then Exit Function r = ReadProcessMemory(GetCurrentProcess(), hCharBlck, btCharset(1), lLen) lCharset = btCharset(3) + btCharset(4) * &H100 + _ btCharset(1) * &H10000 + btCharset(2) * &H1000000 sCharset$ = Hex$(lCharset) sCharset$ = String(8 - Len(sCharset$), "0") & sCharset$ sVerInfo(1) = "CompanyName" sVerInfo(2) = "FileDescription" sVerInfo(3) = "FileVersion" sVerInfo(4) = "InternalName" sVerInfo(5) = "LegalCopyright" sVerInfo(6) = "OriginalFileName" sVerInfo(7) = "ProductName" sVerInfo(8) = "ProductVersion" sVerInfo(9) = "Comments" For i = 1 To 9 sVerBlck$ = "\StringFileInfo\" & sCharset & "\" & sVerInfo(i) r = VerQueryValue(sVerData, sVerBlck, hVersion, lInfoSize) If r Then sData = String$(lInfoSize, 0) r = ReadProcessMemory(GetCurrentProcess(), hVersion, ByVal sData, lInfoSize) sData = Left$(sData, lInfoSize - 1) With GetVersionInfo Select Case i Case 1: .CompanyName = sData Case 2: .FileDescription = sData Case 3: .FileVersion = sData Case 4: .InternalName = sData Case 5: .LegalCopyright = sData Case 6: .OriginalFileName = sData Case 7: .ProductName = sData Case 8: .ProductVersion = sData Case 9: .Comments = sData End Select If GetBinaryType(Filename, lBinType) Then Select Case lBinType Case SCS_32BIT_BINARY: .FileOS = "Ejecutable Para Windows De 32 Bits" Case SCS_DOS_BINARY: .FileOS = "Ejecutable Para MS-DOS" Case SCS_OS216_BINARY: .FileOS = "Ejecutable Para OS/2 De 16 Bits" Case SCS_PIF_BINARY: .FileOS = "Acceso Directo A Programa De MS-DOS" Case SCS_POSIX_BINARY: .FileOS = "Archivo Ejecutable Para POSIX" Case SCS_WOW_BINARY: .FileOS = "Ejecutable Para Windows De 16 Bits" Case Else: .FileOS = "Sistema Desconocido" End Select End If End With End If Next End Function Function GetPriorityClassName(PriorityClass As Long) As String Dim sName$ Select Case PriorityClass Case HIGH_PRIORITY_CLASS: sName$ = "Alta" Case IDLE_PRIORITY_CLASS: sName$ = "Inactivo" Case NORMAL_PRIORITY_CLASS: sName$ = "Normal" Case REALTIME_PRIORITY_CLASS: sName$ = "Tiempo Real" Case Else: sName$ = "Desconocida" End Select GetPriorityClassName = sName$ End Function Function GetWindowText(hwnd As Long) As String Dim sTitle$, r& sTitle = String$(255, 0): r = Win.GetWindowText(hwnd, sTitle, 255) sTitle = Left$(sTitle, r) GetWindowText = sTitle End Function Function GetFileTitle(Filename As String) As String GetFileTitle = Trim(Replace(Mid$(Filename, InStrRev(Filename, "\") + 1), vbNullChar, vbNullString)) End Function Enjoy!! :P Saludos. |