08.07.2020, 11:36 [+3 UTC]
в нашей команде: 4 662 чел. | участники онлайн: 5 (рекорд: 21)

:: РЕГИСТРАЦИЯ

задать вопрос

все разделы

правила

новости

участники

доска почёта

форум

блоги

поиск

статистика

наш журнал

наши встречи

наша галерея

отзывы о нас

поддержка

руководство

Версия системы:
7.89 (25.04.2020)
JS-v.1.45 | CSS-v.3.39

Общие новости:
13.04.2020, 00:02

Форум:
07.07.2020, 19:11

Последний вопрос:
07.07.2020, 13:03
Всего: 152720

Последний ответ:
08.07.2020, 02:59
Всего: 260323

Последняя рассылка:
07.07.2020, 20:15

Писем в очереди:
0

Мы в соцсетях:

Наша кнопка:

RFpro.ru - здесь вам помогут!

Отзывы о нас:
21.08.2019, 09:22 »
dar777
Это самое лучшее решение! [вопрос № 196149, ответ № 278550]
30.12.2010, 07:57 »
Pinokio
Отличный ответ, большое спасибо. Разобрался с NetBeans, очень удобная программа (хотя пока не нашел ошибку из-за которой не происходит регистрация, зато нашел другую smile ). Большое спасибо. [вопрос № 181631, ответ № 265127]
07.08.2011, 05:39 »
Петровский Г И
Спасибо за подробный ответ.Процессор возьму под разгон без боксового кулера и cooler master vortex plus.Плату Gigabyte. [вопрос № 183839, ответ № 268003]

РАЗДЕЛ • Pascal / Delphi / Lazarus

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

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

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

Зенченко Константин Николаевич
Статус: Старший модератор
Рейтинг: 303
puporev
Статус: Профессор
Рейтинг: 73
Лысков Игорь Витальевич
Статус: Мастер-Эксперт
Рейтинг: 0

Перейти к консультации №:
 

Консультация онлайн # 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

Рейтинг ответа:

0

[подробно]

Сообщение
модераторам

Отправлять сообщения
модераторам могут
только участники портала.
ВОЙТИ НА ПОРТАЛ »
регистрация »

Мини-форум консультации № 146210
Евгений/Genia007/
Профессионал

ID: 153662

# 1

= общий = | 06.10.2008, 22:03 | цитировать цитировать  | профиль профиль  |  отправить письмо в личную почту пейджер

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

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

неизвестный

# 2

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

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

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

неизвестный

# 3

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

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

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

Евгений/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

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

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

 

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

Rambler's Top100

главная страница | поддержка | задать вопрос

Время генерирования страницы: 0.17446 сек.

© 2001-2020, Портал RFPRO.RU, Россия
Калашников О.А.  |  Гладенюк А.Г.
Версия системы: 7.89 от 25.04.2020
Версия JS: 1.45 | Версия CSS: 3.39