unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Windows, jwaTlHelp32, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ComCtrls,
StdCtrls, JwaPsApi, LazUTF8;
const
SE_CREATE_TOKEN_NAME = 'SeCreateTokenPrivilege';
SE_ASSIGNPRIMARYTOKEN_NAME = 'SeAssignPrimaryTokenPrivilege';
SE_LOCK_MEMORY_NAME = 'SeLockMemoryPrivilege';
SE_INCREASE_QUOTA_NAME = 'SeIncreaseQuotaPrivilege';
SE_UNSOLICITED_INPUT_NAME = 'SeUnsolicitedInputPrivilege';
SE_MACHINE_ACCOUNT_NAME = 'SeMachineAccountPrivilege';
SE_TCB_NAME = 'SeTcbPrivilege';
SE_SECURITY_NAME = 'SeSecurityPrivilege';
SE_TAKE_OWNERSHIP_NAME = 'SeTakeOwnershipPrivilege';
SE_LOAD_DRIVER_NAME = 'SeLoadDriverPrivilege';
SE_SYSTEM_PROFILE_NAME = 'SeSystemProfilePrivilege';
SE_SYSTEMTIME_NAME = 'SeSystemtimePrivilege';
SE_PROF_SINGLE_PROCESS_NAME = 'SeProfileSingleProcessPrivilege';
SE_INC_BASE_PRIORITY_NAME = 'SeIncreaseBasePriorityPrivilege';
SE_CREATE_PAGEFILE_NAME = 'SeCreatePagefilePrivilege';
SE_CREATE_PERMANENT_NAME = 'SeCreatePermanentPrivilege';
SE_BACKUP_NAME = 'SeBackupPrivilege';
SE_RESTORE_NAME = 'SeRestorePrivilege';
SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
SE_DEBUG_NAME = 'SeDebugPrivilege';
SE_AUDIT_NAME = 'SeAuditPrivilege';
SE_SYSTEM_ENVIRONMENT_NAME = 'SeSystemEnvironmentPrivilege';
SE_CHANGE_NOTIFY_NAME = 'SeChangeNotifyPrivilege';
SE_REMOTE_SHUTDOWN_NAME = 'SeRemoteShutdownPrivilege';
SE_UNDOCK_NAME = 'SeUndockPrivilege';
SE_SYNC_AGENT_NAME = 'SeSyncAgentPrivilege';
SE_ENABLE_DELEGATION_NAME = 'SeEnableDelegationPrivilege';
SE_MANAGE_VOLUME_NAME = 'SeManageVolumePrivilege';
type
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
ListView1: TListView;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
public
end;
var
Form1: TForm1;
function QueryFullProcessImageNameW(hProcess: THandle; dwFlags: DWORD;
lpExeName: LPWSTR; var lpdwSize: DWORD): BOOL; stdcall; external kernel32;
implementation
{$R *.lfm}
{ TForm1 }
function obtenerInfoFichero (info : string; fichero : string) : string;
type
PaLeerBuffer = array [0..MAX_PATH] of char;
var
Size, Size2 : DWord;
Pt, Pt2 : Pointer;
Idioma : string;
begin
Result := '';
Size := GetFileVersionInfoSize(PChar (fichero), Size2);
if Size > 0 then
begin
GetMem (Pt, Size);
if GetFileVersionInfo (PChar (fichero), 0, Size, Pt) then
begin
VerQueryValue( Pt, '\VarFileInfo\Translation',Pt2, Size2);
Idioma:=IntToHex( DWord(Pt2^) ,8 );
Idioma:=Copy(Idioma,5,4)+Copy(Idioma,1,4);
VerQueryValue( Pt,Pchar('\StringFileInfo\'+Idioma+'\'+info),Pt2, Size2);
if Size2 > 0 then
begin
Result:=WinCPToUTF8(Copy(PaLeerBuffer(Pt2^),1,Size2)); // modificado
end
else
result := '';
FreeMem (Pt);
end;
end
else
result := '';
end;
function NTSetPrivilege(sPrivilege: string; bEnabled: Boolean): Boolean;
var
hToken: THandle;
TokenPriv: TOKEN_PRIVILEGES;
PrevTokenPriv: TOKEN_PRIVILEGES;
ReturnLength: Cardinal;
begin
Result := True;
// Only for Windows NT/2000/XP and later.
if not (Win32Platform = VER_PLATFORM_WIN32_NT) then Exit;
Result := False;
// obtain the processes token
if OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
begin
try
// Get the locally unique identifier (LUID) .
if LookupPrivilegeValue(nil, PChar(sPrivilege),
TokenPriv.Privileges[0].Luid) then
begin
TokenPriv.PrivilegeCount := 1; // one privilege to set
case bEnabled of
True: TokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
False: TokenPriv.Privileges[0].Attributes := 0;
end;
ReturnLength := 0; // replaces a var parameter
PrevTokenPriv := TokenPriv;
// enable or disable the privilege
AdjustTokenPrivileges(hToken, False, TokenPriv, SizeOf(PrevTokenPriv),
PrevTokenPriv, ReturnLength);
end;
finally
CloseHandle(hToken);
end;
end;
// test the return value of AdjustTokenPrivileges.
Result := GetLastError = ERROR_SUCCESS;
if not Result then
raise Exception.Create(SysErrorMessage(GetLastError));
end;
function GetProcessPath(PID: DWORD): string;
const
PROCESS_QUERY_LIMITED_INFORMATION = $1000;
var
HProcess: THandle;
WBuf: UnicodeString;
Len: DWORD;
begin
Result := '';
HProcess := OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, False, PID);
if HProcess <> 0 then
try
SetLength(WBuf, 1000);
Len := 1000 + 1;
if QueryFullProcessImageNameW(HProcess, 0, Pointer(WBuf), Len) then
begin
SetLength(WBuf, Len);
Result := UTF8Encode(WBuf);
end;
finally
CloseHandle(HProcess);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
const
PROCESS_QUERY_LIMITED_INFORMATION = $1000;
var
Snapshot, hProcess: THandle;
ProcInfo: TProcessEntry32;
pmc: _PROCESS_MEMORY_COUNTERS; // for ram used
begin
NTSetPrivilege(SE_DEBUG_NAME,true);
pmc.cb := SizeOf(pmc) ; // me quede por aqui
Snapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if Snapshot <> INVALID_HANDLE_VALUE then
try
ProcInfo.dwSize := SizeOf(ProcInfo);
if Process32First(Snapshot, ProcInfo) then
repeat
with ListView1.Items.Add do
begin
Caption := UTF8Encode(ProcInfo.szExeFile); // name process
SubItems.Append(IntToStr(ProcInfo.th32ProcessID)); // PID process
SubItems.Append(GetProcessPath(ProcInfo.th32ProcessID)); // path process
// CODE FOR GET RAM USED FOR EACH PROCESS
hProcess := OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, False, ProcInfo.th32ProcessID);
if HProcess <> 0 then
begin
if GetProcessMemoryInfo(hProcess, pmc, sizeof(pmc)) then
begin
// Usage in Bytes: pmc.WorkingSetSize
SubItems.Append(IntToStr(pmc.WorkingSetSize)); // ram used of process (bytes)
end
else
begin
// fail
SubItems.Append('');
end;
end
else
begin
SubItems.Append('');
end;
SubItems.Append(obtenerInfoFichero('FileDescription', GetProcessPath(ProcInfo.th32ProcessID))); // description of process
SubItems.Append(obtenerInfoFichero('CompanyName', GetProcessPath(ProcInfo.th32ProcessID))); // company name
end;
until not Process32Next(Snapshot, ProcInfo);
finally
CloseHandle(Snapshot);
end;
form1.Caption:='Total Process: '+inttostr(ListView1.Items.Count);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
end;
end.