FAQ VCL
Windows

:: Меню ::
:: На главную ::
:: FAQ ::
:: Заметки ::
:: Практика ::
:: Win API ::
:: Проекты ::
:: Скачать ::
:: Секреты ::
:: Ссылки ::

:: Сервис ::
:: Написать ::

:: MVP ::

:: RSS ::

Яндекс.Метрика

Как перехватить нажатие клавиш в Windows, даже если приложение неактивно?

// Timer1.Interval = 100
procedure TForm1.Timer1Timer(Sender: TObject);
begin
   if GetAsyncKeyState( VK_RETURN ) <> 0 then
      ShowMessage( 'Вы нажали на Enter' );
   if GetAsyncKeyState( VK_SPACE ) <> 0 then
      ShowMessage( 'Вы нажали на Space' );
   if GetAsyncKeyState( VK_ESCAPE ) <> 0 then
      ShowMessage( 'Вы нажали на Escape' );
end;


Как включить/отключить перерисовку окна при его перетаскивании?

// Способ первый
procedure SetDragFullWindows( check: boolean );
var
  flag: boolean;
begin
   if check then
      SystemParametersInfo( SPI_SETDRAGFULLWINDOWS, 1, @flag, 0 )
   else
      SystemParametersInfo( SPI_SETDRAGFULLWINDOWS, 0, @flag, 0 );
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   SetDragFullWindows( true );
end;

// Способ второй
procedure SetDragFullWindows( check: boolean );
begin
   SystemParametersInfo( SPI_SETDRAGFULLWINDOWS, Ord( check ), nil, 0 );
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   SetDragFullWindows( true );
end;


Как реализовать функцию "свернуть все окна"?

// Способ первый
procedure MinimizeAll;
var
  Wnd: HWND;
begin
   Wnd := FindWindow('Shell_TrayWnd', nil);
   if Wnd <> 0 then
      SendMessage(Wnd, WM_COMMAND, $019F, 0);
end;

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

procedure TForm1.Button1Click(Sender: TObject);
var
  z: OleVariant;
begin
   z := CreateOleObject( 'Shell.Application' );
   z.MinimizeAll; // или z.ToggleDesktop;
   z := Unassigned;
end;

// Способ третий
procedure TForm1.Button1Click(Sender: TObject);
begin
   keybd_event(VK_LWIN, 0, 0, 0);
   keybd_event(Ord('M'), 0, 0, 0);
   keybd_event(Ord('M'), 0, KEYEVENTF_KEYUP, 0);
   keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0);
end;


Как включить/отключить режим автоскрытия у панели задач?

uses
  {...,} ShellAPI;

// Включить режим автоскрытия
procedure TForm1.Button1Click(Sender: TObject);
var
  pData: TAppBarData;
begin
   ZeroMemory(@pData, SizeOf(TAppBarData));
   pData.cbSize := SizeOf(TAppBarData);
   pData.hWnd := FindWindow('Shell_TrayWnd', nil);
   pData.lParam := ABS_ALWAYSONTOP or ABS_AUTOHIDE;
   SHAppBarMessage(ABM_SETSTATE, pData);
end;

// Отключить режим автоскрытия
procedure TForm1.Button2Click(Sender: TObject);
var
  pData: TAppBarData;
begin
   ZeroMemory(@pData, SizeOf(TAppBarData));
   pData.cbSize := SizeOf(TAppBarData);
   pData.hWnd := FindWindow('Shell_TrayWnd', nil);
   pData.lParam := ABS_ALWAYSONTOP;
   SHAppBarMessage(ABM_SETSTATE, pData);
end;


Как определить расположение панели задач на экране?

uses
  {...,} ShellAPI;

function DetectTaskBarPos: UInt;
var
  AppBarData: TAppBarData;
  ClientRect, Rect: TRect;
begin
   AppBarData.hWnd := FindWindow( 'Shell_TrayWnd', nil );
   GetClientRect( AppBarData.hWnd, ClientRect );
   GetWindowRect( AppBarData.hwnd, Rect );
   if ( Rect.Top > 0 ) then
      Result := ABE_BOTTOM
   else
   if ( Rect.Bottom < Screen.Height ) then
      Result := ABE_TOP
   else
   if Rect.Right < Screen.Width then
      Result := ABE_LEFT
   else
      Result := ABE_RIGHT;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   case DetectTaskBarPos of
      ABE_LEFT: ShowMessage( 'Панель находится слева' );
      ABE_RIGHT: ShowMessage( 'Панель находится справа' );
      ABE_TOP: ShowMessage( 'Панель находится вверху' );
      ABE_BOTTOM: ShowMessage( 'Панель находится внизу' );
   end;
end;


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

uses
  {...,} Registry;

procedure ChangeWallpaper( WallPath: string );
var
  Reg: TRegistry;
begin
   with TRegistry.Create do
   begin
      RootKey := HKEY_CURRENT_USER;
      OpenKey( 'Control Panel\Desktop', false );
      WriteString( 'Wallpaper', WallPath );
      CloseKey;
      Free;
   end;
   SystemParametersInfo( SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE );
end;

// Более универсальный вариант
uses
  {...,} Registry, ShlObj, ComObj;

procedure ChangeWallpaper( WallPath: string );
var
  Reg: TRegistry;
  ActiveDesktop: IActiveDesktop;
begin
   with TRegistry.Create do
   begin
      RootKey := HKEY_CURRENT_USER;
      OpenKey( 'Control Panel\Desktop', false );
      WriteString( 'Wallpaper', WallPath );
      CloseKey;
      Free;
   end;
   SystemParametersInfo( SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE );
   ActiveDesktop := CreateComObject( CLSID_ActiveDesktop ) as IActiveDesktop;
   ActiveDesktop.ApplyChanges( AD_APPLY_ALL or AD_APPLY_FORCE );
end;


Как изменить стиль отображения обоев на рабочем столе?

uses
  {...,} Registry;

// Pos = 0 - по цунтру
//     = 1 - замостить
//     = 2 - растянуть
procedure ChangeWallpaperPos( Pos: byte );
var
  Reg: TRegistry;
begin
   with TRegistry.Create do
   begin
      RootKey := HKEY_CURRENT_USER;
      OpenKey( 'Control Panel\Desktop', false );
      case Pos of
         0: begin
            WriteString( 'TileWallpaper', '0' );
            WriteString( 'WallpaperStyle', '0' );
         end;
         1: begin
            WriteString( 'TileWallpaper', '1' );
            WriteString( 'WallpaperStyle', '0' );
         end;
         2: begin
            WriteString( 'TileWallpaper', '0' );
            WriteString( 'WallpaperStyle', '2' );
         end;
      end;
      CloseKey;
      Free;
   end;
   SystemParametersInfo( SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE );
end;


Как включить Drop Shadow Effect окна в Windows XP?

type 
  TForm1 = class(TForm) 
  protected 
    procedure CreateParams( var Params: TCreateParams ); override; 
  end;

procedure TForm1.CreateParams(var Params: TCreateParams); 
const 
  CS_DROPSHADOW = $00020000; 
begin 
   inherited; 
   Params.WindowClass.Style := Params.WindowClass.Style or CS_DROPSHADOW; 
end;


Как определить время простаивания системы?

function LastInput: DWord;
var
  LInput: TLastInputInfo;
begin
   LInput.cbSize := SizeOf( TLastInputInfo );
   GetLastInputInfo( LInput );
   Result := GetTickCount - LInput.dwTime;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
   Caption := Format( 'Система простаивает %d ms', [LastInput] );
end;


Как изменить шрифт и выравнивание в заголовке формы?

function IsAdmin: boolean;
const
  SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = ( Value: ( 0, 0, 0, 0, 0, 5 ) );
  SECURITY_BUILTIN_DOMAIN_RID = $00000020;
  DOMAIN_ALIAS_RID_ADMINS = $00000220;
var
  hAccessToken: THandle;
  ptgGroups: PTokenGroups;
  dwInfoBufferSize: DWORD;
  psidAdministrators: PSID;
  i: Integer;
  bSuccess: BOOL;
begin
   Result := false;
   bSuccess := OpenThreadToken( GetCurrentThread, TOKEN_QUERY, true, hAccessToken );
   if not bSuccess then
   begin
     if GetLastError = ERROR_NO_TOKEN then
        bSuccess := OpenProcessToken( GetCurrentProcess, TOKEN_QUERY, hAccessToken );
   end;
   if bSuccess then
   begin
      GetMem( ptgGroups, 1024 );
      bSuccess := GetTokenInformation( hAccessToken, TokenGroups,
                                       ptgGroups, 1024, dwInfoBufferSize );
      CloseHandle( hAccessToken );
      if bSuccess then
      begin
         AllocateAndInitializeSid( SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID,
                                   DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdministrators );
         {$R-}
         for i := 0 to ptgGroups.GroupCount-1 do
         if EqualSid( psidAdministrators, ptgGroups.Groups[i].Sid ) then
         begin
            Result := true;
            Break;
         end;
         {$R+}
         FreeSid( psidAdministrators );
      end;
      FreeMem( ptgGroups );
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   case IsAdmin of
      true: ShowMessage( 'У нас есть права администратора' );
      false: ShowMessage( 'У нас нет прав администратора' );
   end;
end;

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