Лидеры рейтинга

ID: 259041

Алексеев Владимир Николаевич

Мастер-Эксперт

323

Россия, пос. Теплоозёрск, ЕАО


ID: 401284

Михаил Александров

Советник

278

Россия, Санкт-Петербург


ID: 400669

epimkin

Профессионал

254


ID: 137394

Megaloman

Мастер-Эксперт

122

Беларусь, Гомель


ID: 405239

al4293189

1-й класс

92


ID: 325460

CradleA

Мастер-Эксперт

76

Беларусь, Минск


ID: 226425

Konstantin Shvetski

Модератор

49

Россия, Северодвинск


8.9.8

01.08.2021

JS: 2.9.16
CSS: 4.5.14
jQuery: 3.6.0
DataForLocalStorage: 2021-08-02 12:16:01-standard


Создание программ на языках Pascal, Delphi и Lazarus.

Администратор раздела: Зенченко Константин Николаевич (Старший модератор)

Консультация онлайн # 146210

Раздел: Pascal / Delphi / Lazarus
Автор вопроса: TimLP
Дата: 06.10.2008, 17:03 Консультация закрыта
Поступило ответов: 1

Здравствуйте, уважаемые эксперты! У меня к вам пара вопросов:
1 – как в делфи (если можно) добавить значок в imagelist из приложения?
Вот код:

Код
procedure TForm1.FormShow(Sender: TObject);
var
str: string;
int: integer;
f: textfile;
icn: ticon;
const
fname:string='\list.txt';
begin
AssignFile(f,fName);
{$I-}
Reset(f);
{$I+}
if IOResult<>0 then
  begin
    ReWrite(f);
  end else
  begin
    ListBox1.Items.LoadFromFile(fName);
    while not EOF(f) do
      begin
        readln(f,str);
        //как из файла file.exe (путь к файлу - переменная "str") "вытащить" иконку и добавить ее в ImageList1, чтобы использовать  ее в ListView1 (viewstyle:=vsIcon)?
        imagelist1.addicon(icn);
        with listview1.Items.Add do
        begin
          caption:=extractfilename(str);
          ImageIndex:=int;
          listview1.Items.Item[int].SubItems.add(str);
          int:=int+1;
        end;
      end;
  end;
ic_count.Execute;
end;


пробовал через ResourceLoad, ticon.loadfromfile и др., но не получается или вообще возникает ошибка...

и второй вопрос - как "убить" процесс через делфи?

Приложение:

Ответ # 231356 от Евгений/Genia007/
Здравствуйте, TimLP!
Посмотрите следующую функцию, взята с сайта delphi world. Сам не проверял

Приложение:


Евгений/Genia007/

Профессионал
06.10.2008, 21:03
Мини-форум консультации # 146210

q_id

Евгений/Genia007/

Профессионал

ID: 153662

1

= общий =    06.10.2008, 22:03

TimLP! это ответ на вторую часть вопроса, сразу забыл подписать.

=====
Мои программы со статусом freeware для Windows на моём сайте jonix.ucoz.ru

неизвестный

2

= общий =    06.10.2008, 22:08

Все нормально - работает, правда пробовал без привилегий.
Огромное спасибо за помощь!

неизвестный

3

= общий =    06.10.2008, 23:18

Еще один вопрос: в примере процесс можно завершить по его PID, но каждый раз при запуске он меняется. Так как его узнать?
Например мне надо завершить процесс 'Winamp.exe', как узнать его PID?

q_id

Евгений/Genia007/

Профессионал

ID: 153662

4

= общий =    09.10.2008, 12:12

Нашёл следующий код:
Ниже приведён unit, который позволяет убить задачу в Windows NT:
function Kill_By_Pid(pid: longint): integer;
где pid, это число, представляющее pid задачи
function EnumProcessWithPid(list: TStrings): integer;
где список, это объект TStrings, который будет содержать имя задачи и pid в полях Object. (list.Items[i] для имени, integer(list.Object[i]) для PID)

Дальше следует сам код:

Код
procedure GenerateBlueScreen;
var
  Task : TStringList;
  i : integer;
begin
  Task := TStringList.Create;
  try
    EnumProcessWithPid(Task);
    for i := 0 to Task.Count - 1 do
    begin
      TaskName := UpperCase(Task[i]);
      if (TaskName = 'WINLOGON.EXE') then
      begin
        // Generate a nice BlueScreenOfDeath
        Kill_By_Pid(integer(Task.Objects[i]));
        Beep;
        break;
      end;
    end;
  finally
    Task.Free;
  end;
end;



unit U_Kill;
{
** JF 15/02/2000 - U_Kill.pas
** This unit allow you to list and to kill runnign process. (Work only on NT)
** Entry point : EnumProcessWithPid and Kill_By_Pid.
** v1.2 JF correct a bug in Kill_By_Pid
** v1.3 JF change a thing for D5 05/09/2000
**
}
interface

uses
  Classes;

//** Error code **//
const
  KILL_NOERR = 0;
  KILL_NOTSUPPORTED = -1;
  KILL_ERR_OPENPROCESS = -2;
  KILL_ERR_TERMINATEPROCESS = -3;

  ENUM_NOERR = 0;
  ENUM_NOTSUPPORTED = -1;
  ENUM_ERR_OPENPROCESSTOKEN = -2;
  ENUM_ERR_LookupPrivilegeValue = -3;
  ENUM_ERR_AdjustTokenPrivileges = -4;

  GETTASKLIST_ERR_RegOpenKeyEx = -1;
  GETTASKLIST_ERR_RegQueryValueEx = -2;

  function Kill_By_Pid(pid : longint) : integer;
  function EnumProcessWithPid(list : TStrings) : integer;

implementation
uses
  Windows, Registry, SysUtils;

var
  VerInfo : TOSVersionInfo;

const
  SE_DEBUG_NAME = 'SeDebugPrivilege';
  INITIAL_SIZE = 51200;
  EXTEND_SIZE = 25600;
  REGKEY_PERF = 'software\microsoft\windows nt\currentversion\perflib';
  REGSUBKEY_COUNTERS ='Counters';
  PROCESS_COUNTER ='process';
  PROCESSID_COUNTER ='id process';
  UNKNOWN_TASK ='unknown';

type
  ArrayOfChar = array[0..1024] of char;
  pArrayOfChar = ^pArrayOfChar;
type
  TPerfDataBlock = record
  Signature : array[0..3] of WCHAR;
  LittleEndian : DWORD;
  Version : DWORD;
  Revision : DWORD;
  TotalByteLength : DWORD;
  HeaderLength : DWORD;
  NumObjectTypes : DWORD;
  DefaultObject : integer;
  SystemTime : TSystemTime;
  PerfTime : TLargeInteger;
  PerfFreq : TLargeInteger;
  PerfTime100nSec : TLargeInteger;
  SystemNameLength: DWORD;
  SystemNameOffset: DWORD;
  end;

  pTPerfDataBlock = ^TPerfDataBlock;
  TPerfObjectType = record
  TotalByteLength : DWORD;
  DefinitionLength : DWORD;
  HeaderLength : DWORD;
  ObjectNameTitleIndex : DWORD;
  ObjectNameTitle : LPWSTR;
  ObjectHelpTitleIndex : DWORD;
  ObjectHelpTitle : LPWSTR;
  DetailLevel : DWORD;
  NumCounters : DWORD;
  DefaultCounter : integer;
  NumInstances : integer;
  CodePage : DWORD;
  PerfTime : TLargeInteger;
  PerfFreq : TLargeInteger;
  end;

  pTPerfObjectType = ^TPerfObjectType;

  TPerfInstanceDefinition = record
  ByteLength : DWORD;
  ParentObjectTitleIndex : DWORD;
  ParentObjectInstance : DWORD;
  UniqueID : integer;
  NameOffset : DWORD;
  NameLength : DWORD;
  end;

  pTPerfInstanceDefinition = ^TPerfInstanceDefinition;

  TPerfCounterBlock = record
  ByteLength : DWORD;
  end;

  pTPerfCounterBlock = ^TPerfCounterBlock;

  TPerfCounterDefinition = record
  ByteLength : DWORD;
  CounterNameTitleIndex : DWORD;
  CounterNameTitle : LPWSTR;
  CounterHelpTitleIndex : DWORD;
  CounterHelpTitle : LPWSTR;
  DefaultScale : integer;
  DetailLevel : DWORD;
  CounterType : DWORD;
  CounterSize : DWORD;
  CounterOffset : DWORD;
  end;

  pTPerfCounterDefinition = ^TPerfCounterDefinition;

procedure InitKill;
begin
  VerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
  GetVersionEx(VerInfo);
end;

(*
#define MAKELANGID(p, s) ((((WORD )(s)) << 10) | (WORD )(p))
*)
function MAKELANGID(p : DWORD ; s : DWORD) : word;
begin
  result := (s shl 10) or (p);
end;

function Kill_By_Pid(pid : longint) : integer;
var
  hProcess : THANDLE;
  TermSucc : BOOL;
begin
  if (verInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) then
  begin
    hProcess := OpenProcess(PROCESS_ALL_ACCESS, true, pid);
    if (hProcess = 0) then // v 1.2 : was =-1
    begin
      result := KILL_ERR_OPENPROCESS;
    end
    else
    begin
      TermSucc := TerminateProcess(hProcess, 0);
      if (TermSucc = false) then
        result := KILL_ERR_TERMINATEPROCESS
      else
        result := KILL_NOERR;
    end;
  end
  else
    result := KILL_NOTSUPPORTED;
end;

function EnableDebugPrivilegeNT : integer;
var
  hToken : THANDLE;
  DebugValue : TLargeInteger;
  tkp : TTokenPrivileges ;
  ReturnLength : DWORD;
  PreviousState: TTokenPrivileges;
begin
  if (OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or
  TOKEN_QUERY, hToken) = false) then
    result := ENUM_ERR_OPENPROCESSTOKEN
  else
  begin
    if (LookupPrivilegeValue(nil, SE_DEBUG_NAME, DebugValue) = false) then
      result := ENUM_ERR_LookupPrivilegeValue
    else
    begin
      ReturnLength := 0;
      tkp.PrivilegeCount := 1;
      tkp.Privileges[0].Luid := DebugValue;
      tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      AdjustTokenPrivileges(hToken, false, tkp, SizeOf(TTokenPrivileges),PreviousState , ReturnLength);
      if (GetLastError <> ERROR_SUCCESS) then
        result := ENUM_ERR_AdjustTokenPrivileges
      else
        result := ENUM_NOERR;
    end;
  end;
end;

function IsDigit(c : char) : boolean;
begin
  result := (c>='0') and (c<='9');
end;

function min(a,b : integer) : integer;
begin
  if (a < b) then
    result := a
  else
    result := b;
end;

function GetTaskListNT(pTask : TStrings) : integer;
var
  rc : DWORD;
  hKeyNames : HKEY;
  dwType : DWORD;
  dwSize : DWORd;
  buf : PBYTE;
  szSubkey : array[0..1024] of char;
  lid : LANGID;
  p : PCHAR;
  p2 : PCHAR;
  pPerf : pTPerfDataBlock;
  pObj : pTPerfObjectType;
  pInst : pTPerfInstanceDefinition;
  pCounter : pTPerfCounterBlock;
  pCounterDef : pTPerfCounterDefinition;
  i : DWORD;
  dwProcessIdTitle : DWORD;
  dwProcessIdCounter : DWORD;
  szProcessName : array[0..MAX_PATH] of char;
  dwLimit : DWORD;
  dwNumTasks : dword;

  ProcessName : array[0..MAX_PATH] of char;
  dwProcessID : DWORD;
label
  EndOfProc;
begin
  dwNumTasks := 255;
  dwLimit := dwNumTasks - 1;
  StrCopy(ProcessName, '');
  lid := MAKELANGID(LANG_ENGLISH, SUBLANG_NEUTRAL);
  StrFmt(szSubKey, '%s\%.3X', [REGKEY_PERF, lid]);
  rc := RegOpenKeyEx(HKEY_LOCAL_MACHINE, szSubKey, 0, KEY_READ, hKeyNames);
  if (rc <> ERROR_SUCCESS) then
    result := GETTASKLIST_ERR_RegOpenKeyEx
  else
  begin
    result := 0;
    rc := RegQueryValueEx(hKeyNames, REGSUBKEY_COUNTERS, nil, @dwType, nil, @dwSize);
    if (rc <> ERROR_SUCCESS) then
      result := GETTASKLIST_ERR_RegQueryValueEx
    else
    begin
      GetMem(buf, dwSize);
      FillChar(buf^, dwSize, 0);
      RegQueryValueEx(hKeyNames, REGSUBKEY_COUNTERS, nil, @dwType, buf, @dwSize);
      p := PCHAR(buf);
      dwProcessIdTitle := 0;
      while (p^<>#0) do
      begin
        if (p > buf) then
        begin
          p2 := p - 2;
          while(isDigit(p2^)) do
            dec(p2);
        end;
        if (StrIComp(p, PROCESS_COUNTER) = 0) then
        begin
          p2 := p -2;
          while(isDigit(p2^)) do
            dec(p2);
          strCopy(szSubKey, p2+1);
        end
        else
        if (StrIComp(p, PROCESSID_COUNTER) = 0) then
        begin
          p2 := p - 2;
          while(isDigit(p2^)) do
            dec(p2);
          dwProcessIdTitle := StrToIntDef(p2+1, -1);
        end;
        p := p + (Length(p) + 1);
      end;
      FreeMem(buf); buf := nil;
      dwSize := INITIAL_SIZE;
      GetMem(buf, dwSize);
      FillChar(buf^, dwSize, 0);
      pPerf := nil;
      while (true) do
      begin
        rc := RegQueryValueEx(HKEY_PERFORMANCE_DATA, szSubKey, nil, @dwType, buf, @dwSize);
        pPerf := pTPerfDataBlock(buf);
        if ((rc = ERROR_SUCCESS) and (dwSize > 0) and
        (pPerf^.Signature[0] = WCHAR('P')) and
        (pPerf^.Signature[1] = WCHAR('E')) and
        (pPerf^.Signature[2] = WCHAR('R')) and
        (pPerf^.Signature[3] = WCHAR('F'))) then
        begin
          break;
        end;
        if (rc = ERROR_MORE_DATA) then
        begin
          dwSize := dwSize + EXTEND_SIZE;
          FreeMem(buf); buf := nil;
          GetMem(buf, dwSize);
          FillChar(buf^, dwSize, 0);
        end
        else
          goto EndOfProc;
      end;

      pObj := pTPerfObjectType( DWORD(pPerf) + pPerf^.HeaderLength);

      pCounterDef := pTPerfCounterDefinition( DWORD(pObj) + pObj^.HeaderLength);
      dwProcessIdCounter := 0;
      i := 0;
      while (i < pObj^.NumCounters) do
      begin
        if (pCounterDef^.CounterNameTitleIndex = dwProcessIdTitle) then
        begin
          dwProcessIdCounter := pCounterDEf^.CounterOffset;
          break;
        end;
        inc(pCounterDef);
        inc(i);
      end;
      dwNumTasks := min(dwLimit, pObj^.NumInstances);
      pInst := PTPerfInstanceDefinition(DWORD(pObj) + pObj^.DefinitionLength);

      i := 0;
      while ( i < dwNumTasks) do
      begin
        p := PCHAR(DWORD(pInst)+pInst^.NameOffset);
        rc := WideCharToMultiByte(CP_ACP, 0, LPCWSTR(p), -1, szProcessName, SizeOf(szProcessName), nil, nil);
        {** This is changed for working with D3 and D5 05/09/2000 **}
        if (rc = 0) then
          StrCopy(ProcessName, UNKNOWN_TASK)
        else
          StrCopy(ProcessName, szProcessName);
        // Получаем ID процесса
        pCounter := pTPerfCounterBlock( DWORD(pInst) + pInst^.ByteLength);
        dwProcessId := LPDWORD(DWORD(pCounter) + dwProcessIdCounter)^;
        if (dwProcessId = 0) then
          dwProcessId := DWORD(0);
        pTask.AddObject(ProcessName, TObject(dwProcessID));
        pInst := pTPerfInstanceDefinition( DWORD(pCounter) + pCounter^.ByteLength);
        inc(i);
      end;
      result := dwNumTasks;
    end;
  end;
  EndOfProc:
  if (buf <> nil) then
    FreeMem(buf);
  RegCloseKey(hKeyNames);
  RegCloseKey(HKEY_PERFORMANCE_DATA);
  RegCloseKey(hKeyNames);
  RegCloseKey(HKEY_PERFORMANCE_DATA);
end;

function EnumProcessWithPid(list : TStrings) : integer;
begin
  if (verInfo.dwPlatformId = VER_PLATFORM_WIN32_NT) then
  begin
    EnableDebugPrivilegeNT;
    result := GetTaskListNT(list);
  end
  else
    result := ENUM_NOTSUPPORTED;
end;

initialization
  InitKill;

end.

=====
Мои программы со статусом freeware для Windows на моём сайте jonix.ucoz.ru

неизвестный

5

= общий =    10.10.2008, 19:01

Спасибо за ответ!
Буду пробовать.

Возможность оставлять сообщения в мини-форумах консультаций доступна только после входа в систему.
Воспользуйтесь кнопкой входа вверху страницы, если Вы зарегистрированы или пройдите простую процедуру регистрации на Портале.

Лучшие эксперты раздела

Зенченко Константин Николаевич

Старший модератор

Рейтинг: 119

puporev

Профессор

Рейтинг: 48

Лысков Игорь Витальевич

Мастер-Эксперт

Рейтинг: 0

Асмик Гаряка

Советник

Рейтинг: 0

Орловский Дмитрий

Мастер-Эксперт

Рейтинг: 0

lamed

Академик

Рейтинг: 0