Текущий архив: 2010.02.07;
Скачать: CL | DM;

Вниз

Пр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 вся ветка

Текущий архив: 2010.02.07;
Скачать: CL | DM;

Наверх

Память: 0.5 MB
Время: 0.009 c