Программирование на Delphi

FAQ VCL
Windows

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Как скрыть/показать иконки на рабочем столе?


procedure ShowDesktop(Show: Boolean);
var
  h: THandle;
begin
  h := FindWindow('Progman', nil);
  h := GetWindow(h, GW_CHILD);
  if Show then
    ShowWindow(h, SW_SHOW)
  else
    ShowWindow(h, SW_HIDE);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  // Показать
  ShowDesktop(True);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  // Скрыть
  ShowDesktop(False);
end;

Как включить/отключить рабочий стол и все объекты на нем?


procedure TForm1.Button1Click(Sender: TObject);
begin
  // Включить
  EnableWindow(FindWindowEx(FindWindow('Progman', nil), 0, 'ShellDll_DefView', nil), True);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  // Отключить
  EnableWindow(FindWindowEx(FindWindow('Progman', nil), 0, 'ShellDll_DefView', nil), False);
end;

Как добавить иконки в стандартный MessageBox?


// Для Delphi < 2009
// function MessageBoxIndirect(const MsgBoxParams: TMsgBoxParams): Integer; stdcall;
//   external user32 name 'MessageBoxIndirectA';
// Для Delphi >= 2009
function MessageBoxIndirect(const MsgBoxParams: TMsgBoxParams): Integer; stdcall;
  external user32 name 'MessageBoxIndirectW';

implementation

function MessageBoxWithIcon(hWnd: HWND; const lpText, lpCaption: string;
  uType: DWORD; szIcon: PWChar): Integer;
var
  mbp: TMsgBoxParams;
begin
  ZeroMemory(@mbp, SizeOf(mbp));

  with mbp do
  begin
    cbSize := SizeOf(mbp);
    hwndOwner := hWnd;
    hInstance := SysInit.HInstance;
    lpszText := PChar(lpText);
    lpszCaption := PChar(lpCaption);
    PWChar(lpszIcon) := szIcon;
    dwStyle := uType;
  end;

  Result := MessageBoxIndirect(mbp);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  MessageBoxWithIcon(Handle, 'Привет', 'Сообщение с иконкой!', MB_USERICON or MB_APPLMODAL, 'MAINICON');
end;

// ===================================================
// А вот вариант без импортирования MessageBoxIndirect
// ===================================================

function MessageBoxWithIcon(hWnd: HWND; const lpText, lpCaption: string;
  uType: DWORD; szIcon: PWChar): Integer;
var
  mbp: TMsgBoxParams;
begin
  ZeroMemory(@mbp, SizeOf(mbp));

  with mbp do
  begin
    cbSize := SizeOf(mbp);
    hwndOwner := hWnd;
    hInstance := SysInit.HInstance;
    lpszText := PChar(lpText);
    lpszCaption := PChar(lpCaption);
    PWChar(lpszIcon) := szIcon;
    dwStyle := uType;
  end;

  Result := Integer(MessageBoxIndirect(mbp));
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  MessageBoxWithIcon(Handle, 'Привет', 'Сообщение с иконкой!', MB_USERICON or MB_APPLMODAL, 'MAINICON');
end;

Как убить задачу зная идентификатор ее процесса (PID)?


// Способ первый
uses
  Tlhelp32;

function KillTask(PID: Cardinal): Integer;
const
  PROCESS_TERMINATE = $0001;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  Result := 0;

  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);

  while Integer(ContinueLoop) <> 0 do
  begin
    if FProcessEntry32.th32ProcessID = PID then
      Result := Integer(TerminateProcess(OpenProcess(
                PROCESS_TERMINATE, BOOL(0),
                FProcessEntry32.th32ProcessID), 0));
    ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  end;

  CloseHandle(FSnapshotHandle);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  KillTask(2772);
end;

// Способ второй
uses
  ShellAPI;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShellExecute(0, 'open', PChar('cmd.exe'), PChar('/C taskkill.exe /PID 2772'), nil, SW_HIDE);
end;

Как вывести сообщение на фиксированное количество времени?


unit MsgBoxTimeOut;

interface

uses
  Windows;

const
  MB_TIMEDOUT = 32000;

  function MessageBoxTimeOut(hWnd: HWND; lpText: PChar; lpCaption: PChar;
    uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

  function MessageBoxTimeOutA(hWnd: HWND; lpText: PChar; lpCaption: PChar;
    uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

  function MessageBoxTimeOutW(hWnd: HWND; lpText: PWideChar; lpCaption: PWideChar;
    uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;

implementation
  {$IFDEF UNICODE}
  function MessageBoxTimeOut; external user32 name 'MessageBoxTimeoutW';
  {$ELSE}
  function MessageBoxTimeOut; external user32 name 'MessageBoxTimeoutA';
  {$ENDIF}
  function MessageBoxTimeOutA; external user32 name 'MessageBoxTimeoutA';
  function MessageBoxTimeOutW; external user32 name 'MessageBoxTimeoutW';

end.

// Использование

uses
  MsgBoxTimeOut;

procedure TForm1.Button1Click(Sender: TObject);
var
  iRet: Integer;
  iFlags: Integer;
begin
  iFlags := MB_OK or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION;
  iRet := MessageBoxTimeOut(Application.Handle, 'Test a timeout of 2 seconds.',
                            'MessageBoxTimeout Test', iFlags, 0, 2000);

  // Здесь, iRet будет = 1 (IDOK), т.к. только одна кнопка (MB_OK)
  ShowMessage(IntToStr(iRet));

  iFlags := MB_YESNO or MB_SETFOREGROUND or MB_SYSTEMMODAL or MB_ICONINFORMATION;
  iRet := MessageBoxTimeout(Application.Handle, 'Test a timeout of 5 seconds.',
                            'MessageBoxTimeout Test', iFlags, 0, 5000);

  // iRet будет равно константе MB_TIMEDOUT если пользователь
  // не нажал ни на какую кнопку, иначе в iRet возвратиться
  // код нажатой кнопки
  case iRet of
    IDYES: // Нажата кнопка Да
      ShowMessage('Yes');
    IDNO: // Нажата кнопка Нет
      ShowMessage('No');
    MB_TIMEDOUT: // Время ожидания истекло
      ShowMessage('TimedOut');
  end;
end;

Как найти элемент окна, имеющий фокус?


function GetFocusedWindow: HWND;
var
  CurrThID, ThID: DWORD;
begin
  Result := GetForegroundWindow;

  if Result <> 0 then
  begin
    CurrThID := GetCurrentThreadId;
    ThID := GetWindowThreadProcessId(Result, nil);
    Result := 0;

    if CurrThID = ThId then
      Result := GetFocus
    else
    begin
      if AttachThreadInput(CurrThID, ThID, True) then
      begin
        Result := GetFocus;
        AttachThreadInput(CurrThID, ThID, False);
      end;
    end;
  end;
end;

Как в Win2000 и выше перехватывать нажатия клавиш CTRL+ESC, ALT+TAB, ALT+ESC, CTRL+SHIFT+ESC, WIN+TAB и т.д.?


// Способ первый
type
  PKbdDllHookStrukt = ^TKbdDllHookStrukt;
  TKbdDllHookStrukt = record
    vkCode: DWORD;
    scanCode: DWORD;
    flags: DWORD;
    time: DWORD;
    dwExtraInfo: PDWORD;
  end;
  KBDLLHOOKSTRUCT = TKbdDllHookStrukt;

const
  LLKHF_ALTDOWN: Cardinal  = KF_ALTDOWN shr 8; // $000000020;

var
  LLKeybHook: HHook;

implementation

function LowLevelKeyboardProc(Code: Integer; WParam: wParam; Msg: PKbdDllHookStrukt): LongInt; stdcall;
var
  Ctrl, Shift, Win: BOOL;
  State: TKeyboardState;
begin
  case Code of
     HC_ACTION: begin
       GetKeyboardState(State);
       Ctrl := (State[VK_CONTROL] and 128) <> 0;
       Shift := (State[VK_SHIFT] and 128) <> 0;
       Win := (GetKeyState(VK_LWIN) < 0) or (GetKeyState(VK_RWIN) < 0);

       // Отключение CTRL+ESC
       if (Msg^.vkCode = VK_ESCAPE) and Ctrl then
       begin
         Result := 1;
         Exit;
       end;

       // Отключение ALT+TAB
       if (Msg^.vkCode = VK_TAB) and (Msg^.flags and LLKHF_ALTDOWN <> 0) then
       begin
         Result := 1;
         Exit;
       end;

       // Отключение ALT+ESC
       if (Msg^.vkCode = VK_ESCAPE) and (Msg^.flags and LLKHF_ALTDOWN <> 0) then
       begin
         Result := 1;
         Exit;
       end;

       // Отключение CTRL+SHIFT+ESC
       if (Msg^.vkCode = VK_ESCAPE) and Ctrl and Shift then
       begin
         Result := 1;
         Exit;
       end;

       // Отключение WIN+TAB
       if (Msg^.vkCode = VK_TAB) and Win then
       begin
         Result := 1;
         Exit;
       end;
     end;
  end;

  Result := CallNextHookEx(LLKeybHook, Code, WParam, LongInt(Msg));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  LLKeybHook := SetWindowsHookEx(WH_KEYBOARD_LL, @LowLevelKeyboardProc, HInstance, 0);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  if LLKeybHook > 0 then
  begin
    UnHookWindowsHookEx(LLKeybHook);
    LLKeybHook := 0;
  end;
end;

// Способ второй
// DLL
library DisableHotKeys;

uses
  SysUtils,
  Windows,
  Messages;

type
  KBDLLHOOKSTRUCT = record
    vkCode: DWORD;
    scanCode: DWORD;
    flags: DWORD;
    time: DWORD;
    dwExtraInfo:Pointer;
  end;
  PKBDLLHOOKSTRUCT = ^KBDLLHOOKSTRUCT;

const
  LLKHF_ALTDOWN  = KF_ALTDOWN shr 8;
  WH_KEYBOARD_LL = 13;

var
  HookHandle: HHOOK = 0;

function KeyboardProc(nCode: Integer; wParam: LongInt; lParam: LongInt): Integer; stdcall;
var
  KeyStroke: Boolean;
  p: PKBDLLHOOKSTRUCT;
begin
  KeyStroke := False;

  if nCode = HC_ACTION then
  begin
    case wParam of
       WM_KEYDOWN, WM_SYSKEYDOWN, WM_KEYUP, WM_SYSKEYUP:
       begin
         p := PKBDLLHOOKSTRUCT(lParam);
         KeyStroke :=
            ((p^.vkCode = VK_LWIN) or (p^.vkCode = VK_RWIN)) or
            ((p^.vkCode = VK_TAB) and ((p^.flags and LLKHF_ALTDOWN) <> 0)) or
            ((p^.vkCode = VK_ESCAPE) and ((p^.flags and LLKHF_ALTDOWN) <> 0)) or
            ((p^.vkCode = VK_ESCAPE) and ((GetKeyState( VK_CONTROL) and $8000) <> 0)) or
            ((p^.vkCode = VK_F4) and ((p^.flags and LLKHF_ALTDOWN) <> 0));
      end;
    end;
  end;

  if KeyStroke then
    Result := 1
  else
    Result := CallNextHookEx(0, nCode, wParam, lParam);
end;

// установка, отключение ловушки
procedure Hook(Run: Boolean); export; stdcall;
begin
  if Run then
    HookHandle := SetWindowsHookEx(WH_KEYBOARD_LL, @KeyboardProc, HInstance, 0)
  else
  begin
    UnhookWindowsHookEx(HookHandle);
    HookHandle := 0;
  end;
end;

exports
  Hook;

begin
end.

// В приложении
// Загрузка DLL
procedure Hook(Run: Boolean) stdcall; external 'DisableHotKeys' name 'Hook';

procedure TForm1.FormCreate(Sender: TObject);
begin
  Hook(True);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Hook(False);
end;

Как показать подсказку в виде баллона там, где часики?


uses
  CommCtrl;

var
  Form1: TForm1;
  hWndTip: THandle;

implementation

procedure ShowBalloonTip(Control: TWinControl; Icon: Integer; Title: PAnsiChar;
  Text: PWideChar; BackCL, TextCL: TColor);
const
  TOOLTIPS_CLASS = 'tooltips_class32';
  TTS_ALWAYSTIP = $01;
  TTS_NOPREFIX = $02;
  TTS_BALLOON = $40;
  TTF_SUBCLASS = $0010;
  TTF_TRANSPARENT = $0100;
  TTF_CENTERTIP = $0002;
  TTM_ADDTOOL = $0400 + 50;
  TTM_SETTITLE = (WM_USER + 32);
  ICC_WIN95_CLASSES = $000000FF;
//type {Если описания структуры нет в CommCtlr}
//  TOOLINFO = packed record
//    cbSize: Integer;
//    uFlags: Integer;
//    hwnd: THandle;
//    uId: Integer;
//    rect: TRect;
//    hinst: THandle;
//    lpszText: PWideChar;
//    lParam: Integer;
//  end;
var
  ti: TOOLINFO;
  hWnd: THandle;
begin
  hWnd := Control.Handle;
  hWndTip := CreateWindow(TOOLTIPS_CLASS, nil,
                          WS_POPUP or TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,
                          0, 0, 0, 0, hWnd, 0, HInstance, nil);

  if hWndTip <> 0 then
  begin
    hWnd := GetDesktopWindow;
    hWndTip := CreateWindow(TOOLTIPS_CLASS, nil,
                            TTS_NOPREFIX or TTS_BALLOON or TTS_ALWAYSTIP,
                            0, 0, 0, 0, 0, 0, 0, nil );
    if hWndTip <> 0 then
    begin
      SetWindowPos(hWndTip, HWND_TOPMOST, 0, 0, 0, 0,
                   SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
      ti.cbSize := SizeOf(ti);
      ti.uFlags := TTF_CENTERTIP or TTF_TRANSPARENT or TTF_TRACK;
      ti.hwnd := hWnd;
      ti.lpszText := Text;
      ti.rect := Rect(0, Screen.WorkAreaHeight, 0, 0);
      SendMessage(hWndTip, TTM_SETTIPBKCOLOR, BackCL, 0);
      SendMessage(hWndTip, TTM_SETTIPTEXTCOLOR, TextCL, 0);
      SendMessage(hWndTip, TTM_ADDTOOL, 1, Integer(@ti));
      SendMessage(hWndTip, TTM_SETTITLE, Icon mod 4, Integer(Title));
      SendMessage(hWndTip, TTM_TRACKPOSITION, 0, MAKELONG(Screen.WorkAreaWidth - 40, Screen.WorkAreaHeight));
      SendMessage(hWndTip, TTM_TRACKACTIVATE, 1, Integer(@ti));

      // Последующим кодом можно убрать сообщение
      // SendMessage(hWndTip, TTM_TRACKACTIVATE, 0, Integer(@ti));
      // SendMessage(hWndTip, TTM_DELTOOLW, 0, 0);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowBalloonTip(Form1, 1, 'Это заголовок.', 'Вот..', $00D9FFFF, clBlack);
end;

Как в Win XP получить список выделенных фалов в windows explorer?


uses
  CommCtrl;

function PrintEnumProc(Wnd: HWND; LParam: LPARAM): BOOL; stdcall;
const
  MaxTextSize = 1024;
var
  PrText: array[0..MaxTextSize] of Char;
  i, Count, State: Integer;
  vBuffer: array[0..255] of Char;
  vProcessId: DWORD;
  vProcess: THandle;
  vPointer: Pointer;
  vNumberOfBytesRead: Cardinal;
  vItem: TLVItem;
begin
  Result := True;

  Windows.GetClassName(Wnd, PrText, MaxTextSize);

  if PrText = 'SysListView32' then
  begin
    Count := SendMessage(Wnd, LVM_GETITEMCOUNT, 0, 0);
    GetWindowThreadProcessId(Wnd, @vProcessId);
    vProcess := OpenProcess(PROCESS_VM_OPERATION or PROCESS_VM_READ or PROCESS_VM_WRITE, False, vProcessId);
    vPointer := VirtualAllocEx(vProcess, nil, 4096, MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE);

    try
      for i := 0 to Count - 1 do
      begin
        State := SendMessage(Wnd, LVM_GETITEMSTATE, i, LVIS_SELECTED);

        if State = LVIS_SELECTED then
        begin
          with vItem do
          begin
            mask := LVIF_TEXT;
            iItem := i;
            iSubItem := 0;
            cchTextMax := SizeOf(vBuffer);
            pszText := Pointer(Cardinal(vPointer) + SizeOf(TLVItem));
          end;

          WriteProcessMemory(vProcess, vPointer, @vItem, SizeOf(TLVItem), vNumberOfBytesRead);
          SendMessage(Wnd, LVM_GETITEM, i, Integer(vPointer));
          ReadProcessMemory(vProcess, Pointer(Cardinal(vPointer) + SizeOf(TLVItem)),
                            @vBuffer[0], SizeOf(vBuffer), vNumberOfBytesRead);
          TMemo(Pointer(LParam)^).Lines.Add(vBuffer);
        end;
      end;
    finally
      VirtualFreeEx(vProcess, vPointer, 0, MEM_RELEASE);
      CloseHandle(vProcess);
    end;

    Result := False;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  W: HWND;
begin
  Memo1.Clear;
  W := FindWindow('CabinetWClass' {'ExploreWClass'}, nil);

  if W = 0 then
    raise Exception.Create('Explorer window not found');

  EnumChildWindows(W, @PrintEnumProc, LPARAM(@Memo1));
end;

Как узнать путь к папке, в которую установлена Windows?


function SystemDir: string;
var
  i: Integer;
begin
  SetLength(Result, MAX_PATH);
  i := GetSystemDirectory(PChar(Result), Length(Result));
  SetLength(Result, i);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(SystemDir);
end;

При использовании материала - ссылка на сайт обязательна