Autor
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!!
Saludos.
En línea
