Программирование на 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;

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