Форум: "WinAPI";
Текущий архив: 2010.02.07;
Скачать: [xml.tar.bz2];
ВнизПр0блемка с T00lHelp32 Найти похожие ветки
← →
[RU].banOK © (2008-12-05 14:15) [0]Здравствуйте ! Пишу Вам , так как сил моих больше нет ...
Вот такая проблема : нужно записать в колонку листвью информацию о пути к процессу , имя пользователя процесса
( надо доделать чтобы показывалось не только мое имя , а еще и system , ну как в виндовом диспетчере задач ) и желательно описание процесса ( у меня есть функция , но не могу связать с кодом :(
Вот первый юнит :
uses
Windows, Messages, SysUtils, Forms, ComCtrls, StdCtrls, XPMan, ExtCtrls,
Controls, Classes , ProcessScaner, TlHelp32, PsApi ;
type
TMainFrm = class(TForm)
ListView1: TListView;
Timer1: TTimer;
private
FScan: TProcessSnapshot;
//идентификатор выбранного процесса - теперь при обновлении списка
//он не теряется.
FSelectedID: Cardinal;
FSelectedName: string;
public
end;
var
MainFrm: TMainFrm;
ProcessHandle: THandle;
ProcessExePath: array[0..127] of Char;
WindowExePath: array[0..127] of Char;
buff: array[0..127] of Char;
Domain, User : array [0..50] of Char;
implementation
{$R *.dfm}
procedure FileVersionInfo;
type
PLangAndCodePage = ^TLangAndCodePage;
TLangAndCodePage = packed record
wLanguage: Word;
wCodePage: Word;
end;
var
I, InfoSize, BlockLength: Cardinal;
pInfo: Pointer;
pLangCP: PLangAndCodePage;
pDesc: PChar;
FileName: string;
begin
FileName:= ProcessExePath;
InfoSize:= GetFileVersionInfoSize(PChar(FileName), Cardinal(nil^));
if InfoSize <> 0 then
begin
GetMem(pInfo, InfoSize);
try
if GetFileVersionInfo(PChar(FileName), 0, InfoSize, pInfo) then
if VerQueryValue(pInfo, "\VarFileInfo\Translation", Pointer(pLangCP), BlockLength) then
for I := 0 to Pred(BlockLength div sizeof(TLangAndCodePage)) do
begin //CompanyName,Legalcopyright
if VerQueryValue(pInfo, PChar(Format("\StringFileInfo\%.4x%.4x\FileDescription",
[pLangCP.wLanguage, pLangCP.wCodePage])), Pointer(pDesc), BlockLength) then
FileDescription:= pDesc;
Inc(pLangCP)
end
finally
FreeMem(pInfo, InfoSize);
end ;
end ;
end;
procedure TMainFrm.UpdateList(Sender: TObject);
var
i: integer;
item: TListItem;
begin
FScan.Update;
~~~~ 0брезан0
with item do
begin
SubItems.Clear;
SubItems.Add(FScan[i].ModuleName);
SubItems.Add (FileDescription + "Надо сделать");
// SubItems.Add(inttostr(FScan[i].Priority));
SubItems.Add(User + "\" + Domain);
end;
end;
procedure TMainFrm.FormCreate(Sender: TObject);
var
hToken: Cardinal;
buf: Pointer;
i: integer;
req_len: Cardinal;
label
realloc;
begin
ProcessHandle := GetCurrentProcess;
GetCurrentUserAndDomain(ProcessHandle, User, chuser, Domain, chDomain);
GetModuleFileNameEx(ProcessHandle, 0, ProcessExePath,127);
FileVersionInfo;
//caoaaouaaai noieuei i?aa neieuei ii?ai anee iu - aaiei iia WinNT
if (GetVersion < $80000000) and OpenProcessToken(GetCurrentProcess,
TOKEN_ALL_ACCESS, hToken) then
try
GetTokenInformation(hToken, TokenPrivileges, nil, 0,
req_len);
realloc:
buf := AllocMem(req_len);
try
if GetTokenInformation(hToken, TokenPrivileges, buf, req_len,
req_len) then
with TOKEN_PRIVILEGES(buf^) do
begin
for i := PrivilegeCount - 1 downto 0 do
Privileges[i].Attributes := Privileges[i].Attributes or
SE_PRIVILEGE_ENABLED;
AdjustTokenPrivileges(hToken, False, TOKEN_PRIVILEGES(buf^),
req_len,
nil, req_len);
end;
finally
FreeMem(buf);
end;
finally
CloseHandle(hToken);
end;
FScan := TProcessSnapshot.Create;
UpdateList(Self);
end;
end.
Так как у вас стоит ограничение я не могу прислать за один раз все :( Сейчас пришлю вторую половину ...
← →
[RU].banOK © (2008-12-05 14:16) [1]А вот второй юнит :
unit ProcessScaner;
interface
uses Windows, TlHelp32, PSAPI, Classes, SysUtils;
type
PTOKEN_USER = ^TOKEN_USER;
_TOKEN_USER = record
User : TSidAndAttributes;
end;
TOKEN_USER = _TOKEN_USER;
PProcessData = ^TProcessData;
TProcessData = record
ModuleName: string;
UserName, Domain: string;
end;
TProcessSnapshot = class(TObject)
private
FProcessList: TList;
function GetCount: Integer;
function GetItem(idx: Integer): TProcessData;
public
procedure Update;
destructor Destroy; override;
constructor Create;
property Count: Integer read GetCount;
property Items[idx: Integer]: TProcessData read GetItem; default;
end;
function GetCurrentUserAndDomain (ProcessHandle: THandle;
szUser : PChar; var chUser: DWORD; szDomain :PChar; var chDomain :
DWORD
):Boolean;
implementation
function GetCurrentUserAndDomain (ProcessHandle: THandle;
szUser : PChar; var chUser: DWORD; szDomain :PChar; var chDomain :
DWORD
):Boolean;
var
hToken : THandle;
cbBuf : Cardinal;
ptiUser : PTOKEN_USER;
snu : SID_NAME_USE;
begin
Result:=false;
if not OpenThreadToken(GetCurrentThread(),TOKEN_QUERY,true,hToken)
then begin
if GetLastError()<> ERROR_NO_TOKEN then exit;
if not OpenProcessToken(ProcessHandle,TOKEN_QUERY,hToken)
then exit;
end;
if not GetTokenInformation(hToken, TokenUser, nil, 0, cbBuf)
then if GetLastError()<> ERROR_INSUFFICIENT_BUFFER
then begin
CloseHandle(hToken);
exit;
end;
if cbBuf = 0 then exit;
GetMem(ptiUser,cbBuf);
if GetTokenInformation(hToken,TokenUser,ptiUser,cbBuf,cbBuf)
then begin
if
LookupAccountSid(nil,ptiUser.User.Sid,szUser,chUser,szDomain,chDomain,snu)
then Result:=true;
end;
CloseHandle(hToken);
FreeMem(ptiUser);
end;
procedure TProcessSnapshot.Update;
var
HProcessSnapshot: Cardinal;
PPE: TProcessEntry32;
i: integer;
process_mem: TProcessMemoryCounters;
procedure AddProcess(id: cardinal; name: string);
var
PEntry: PProcessData;
hProcess: Cardinal;
User, Domain: array[0..50] of char;
chuser, chDomain: cardinal;
ProcHandle: THandle;
begin
New(PEntry);
PEntry^.ModuleName := PPE.szExeFile;
PEntry^.PID := PPE.th32ProcessID;
ProcHandle := OpenProcess(PROCESS_QUERY_INFORMATION , false,
PPE.th32ProcessID);
if ProcHandle > 0 then
begin
GetCurrentUserAndDomain(ProcHandle , User, chuser, Domain,
chDomain);
PEntry^.UserName := User;
PEntry^.Domain := Domain;
end;
if (GetVersion < $80000000) then
begin
hProcess := OpenProcess(PROCESS_QUERY_INFORMATION, False,
PPE.th32ProcessID);
if hProcess <> 0 then
try
if PSApi.GetProcessMemoryInfo(hProcess, @process_mem,
sizeof(process_mem)) then
PEntry^.WorkingSetSize := process_mem.WorkingSetSize else
PEntry^.WorkingSetSize := DWORD(-1);
finally
CloseHandle(hProcess);
end else
PEntry^.WorkingSetSize := DWORD(-1);
//Win9x
end else
PEntry^.WorkingSetSize := DWORD(-1);
FProcessList.Add(PEntry);
end;
begin
for i := FProcessList.Count - 1 downto 0 do
Dispose(FProcessList[i]);
FProcessList.Clear;
begin
HProcessSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if (HProcessSnapshot <> DWORD(-1)) then
try
PPE.dwSize := sizeof(TProcessEntry32);
if (Process32First(HProcessSnapshot, PPE)) then
begin
AddProcess(PPE.th32ProcessID, PPE.szExeFile);
while Process32Next(HProcessSnapshot, PPE) do
AddProcess(PPE.th32ProcessID, PPE.szExeFile);
end else
RaiseLastOSError;
finally
CloseHandle(HProcessSnapshot);
end else RaiseLastOSError;
end;
end;
end.
Вот такой вот код ... Очень прошу , помогите мне !
Иначе я опять заброшу очередной проект :(
С нетерпением жду ответа !
Искренне уважающий Вас программист , [RU].banOK .
← →
Сергей М. © (2008-12-05 14:49) [2]
> проблема : нужно записать
Это не проблема, а задача.
А в чем проблема на пути выполнения задачи ?
> сил моих больше нет
> помогите
> Иначе я опять
Тебе бы на паперть)
← →
[RU].banOK © (2008-12-05 16:38) [3]Ну задача , какая разница !
Посмотрите код , и вы все поймете ! Надо просто реализовать !!!
← →
Сергей М. © (2008-12-05 16:57) [4]
> Надо просто реализовать
Ну так и реализуй !
Никто ж не против)
От форума-то ты что хочешь ? Чтобы кто-то вместо тебя эту работу сделал или что ?
> Посмотрите код , и вы все поймете
Посмотрели. Поняли что код это писал не ты. Кто-то его написал, а ты просто не задумываясь содрал.
Теперь посмотри на код внимательно и сформулируй конкретный вопрос - что тебе в этом коде не понятно ?
← →
Leonid Troyanovsky © (2008-12-05 17:00) [5]Удалено модератором
← →
[RU].banOK © (2008-12-06 17:25) [6]Да идите вы ..... Пойду на другой форум , мне там наверняка помогут
Саппорт блин...
← →
Сергей М. © (2008-12-06 19:35) [7]Идите-идите !
Здесь по пятницам не подают)
← →
Rouse_ © (2008-12-06 19:51) [8]
> Саппорт блин...
О как... печально :)
Страницы: 1 вся ветка
Форум: "WinAPI";
Текущий архив: 2010.02.07;
Скачать: [xml.tar.bz2];
Память: 0.48 MB
Время: 0.006 c