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;

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