FAQ VCL
Форма (приложение)

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

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

:: MVP ::

:: RSS ::

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

Как в Win9x скрыть программу из списка "Завершение работы программы" по CTRL+ALT+DEL?

// Способ первый
var
  Form1: TForm1;

  function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer;
    stdcall; external 'kernel32.dll';

{ Убрать из списка }
procedure TForm1.Button1Click(Sender: TObject);
begin
  if not (csDesigning in ComponentState) then
    RegisterServiceProcess(GetCurrentProcessID, 1);
end;

{ Вернуть обратно }
procedure TForm1.Button2Click(Sender: TObject);
begin
  if not (csDesigning in ComponentState) then
    RegisterServiceProcess(GetCurrentProcessID, 0);
end;

// Способ второй
procedure RegisterServiceProcess;
  stdcall; external 'kernel32.dll' name 'RegisterServiceProcess';

{ Убрать из списка }
procedure TForm1.Button1Click(Sender: TObject);
begin
  asm
    push 1
    push 0
    call RegisterServiceProcess
  end;
end;

{ Вернуть обратно }
procedure TForm1.Button2Click(Sender: TObject);
begin
  asm
    push 0
    push 0
    call RegisterServiceProcess
  end;
end;


Как узнать, была ли перемещена форма?

type
  TForm1 = class(TForm)
  private
    procedure OnMove(var Msg: TWMMove); message WM_MOVE;
    {...}
  end;

procedure TForm1.OnMove(var Msg: TWMMove);
begin
  inherited;
  if Self.Visible then
    ShowMessage('Форма была перемещена');
end;


Как отловить минимизацию окна?

type
  TForm1 = class(TForm)
  private
    procedure OnFormMinimize(var Msg: TMessage); message WM_SYSCOMMAND;
    procedure OnMinimizeProc(Sender:TObject);
    {...}
  end;

// Эта процедура сработает по нажатию кнопки минимизации
// и при выборе пункта "свернуть" в системном меню формы
procedure TForm1.OnFormMinimize(var Msg: TMessage);
begin
  inherited;
  if Msg.WParam = SC_MINIMIZE then
  begin
    // Отловили минимизацию, делаем что нужно
  end;
end;

// Чтобы минимизация срабатывала по нажатию кнопки
// на панели задач, обработаем Application.onMinimize
procedure TForm1.OnMinimizeProc(Sender: TObject);
begin
  PostMessage(Handle, WM_SYSCOMMAND, SC_MINIMIZE, 0);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.onMinimize := OnMinimizeProc;
end;


Как сделать скриншот своей формы и сохранить его в *.bmp файл?

// Способ первый
procedure ScreenMyForm;
var
  c: TCanvas;
  Im: TImage;
  r1, r2: TRect;
begin
  r1 := Rect(Form1.Left, Form1.Top,
             Form1.Left + Form1.Width, Form1.Top + Form1.Height);
  r2 := Rect(0, 0, Form1.Width, Form1.Height);
  try
    Im := TImage.Create(Application);
    Im.Width := Form1.Width;
    Im.Height := Form1.Height;
    c := TCanvas.Create;
    c.Handle := GetDC(GetDesktopWindow);
    Im.Canvas.CopyRect(r2, c, r1);
    Im.Picture.SaveToFile('c:\ScreenMyForm.bmp');
  except
    c.Free;
    Im.Free;
  end;
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
var
  DC: hDC;
  bm: TBitmap;
begin
  DC := GetWindowDC(Handle);
  bm := TBitmap.Create;
  bm.Width := Width;
  bm.Height := Height;
  BitBlt(bm.Canvas.Handle, 0, 0, Width, Height, DC, 0, 0, SRCCOPY);
  bm.SaveToFile('c:\ScreenMyForm.bmp');
  bm.Free;
  ReleaseDC(Handle, DC);
end;

// Способ третий
// С помощью функции PrintWindow
// Появилась начиная с Windows XP (client) и Windows Server 2003 (server)
// Прототип функции - function PrintWindow( HWND: HWND; hdcBlt: HDC; nFlags: DWORD ): BOOL; stdcall; external 'user32.dll';
// ВНИМАНИЕ: закомментированный код может пригодиться в MDI приложениях в Windows Vista и выше, в XP PrintWindow вообще работает коряво.
uses
  {...,} Math;

function WindowSnap(Wnd: HWND; Bmp: TBitmap; ClientOnly: Boolean = False): Boolean;

//  function IsWindowSizebox(Wnd: HWND): Boolean;
//  var
//    Style: Integer;
//  begin
//    Style := GetWindowLong(Wnd, GWL_STYLE);
//    Result := (Style and WS_SIZEBOX) = WS_SIZEBOX;
//  end;
//
//  function IsWindowCaption(Wnd: HWND): Boolean;
//  var
//    Style: Integer;
//  begin
//    Style := GetWindowLong(Wnd, GWL_STYLE);
//    Result := (Style and WS_CAPTION) = WS_CAPTION;
//  end;

const
  PW_CLIENTONLY = 1;
var
  r: TRect;
  DLLHandle: THandle;
  Flags: UINT;
  PrintWindow: function(hwnd: HWND; hdcBlt: HDC; nFlags: UINT): BOOL; stdcall;
begin
  Result := False;
  DLLHandle := GetModuleHandle(user32);

  if DLLHandle <> 0 then
  begin
    @PrintWindow := GetProcAddress(DLLHandle, 'PrintWindow');
    if @PrintWindow <> nil then
    begin
      GetWindowRect(Wnd, r);
      Bmp.Width := r.Right - r.Left;
      Bmp.Height := r.Bottom - r.Top;

//      if ClientOnly then
//      begin
//        if IsWindowSizebox(Wnd) then
//        begin
//           Bmp.Width := Bmp.Width - GetSystemMetrics(SM_CXSIZEFRAME) * 2;
//           Bmp.Height := Bmp.Height - GetSystemMetrics(SM_CYSIZEFRAME) * 2;
//           if IsWindowCaption( Wnd ) then
//             Bmp.Height := Bmp.Height - GetSystemMetrics(SM_CYCAPTION);
//        end
//        else
//        begin
//           Bmp.Width := Bmp.Width - GetSystemMetrics(SM_CXFIXEDFRAME) * 2;
//           Bmp.Height := Bmp.Height - GetSystemMetrics(SM_CYFIXEDFRAME) * 2;
//           if IsWindowCaption( Wnd ) then
//             Bmp.Height := Bmp.Height - GetSystemMetrics(SM_CYCAPTION);
//        end;
//      end;

      Bmp.Canvas.Lock;
      Flags := IfThen(ClientOnly, PW_CLIENTONLY, 0);
      try
        Result := PrintWindow(Wnd, Bmp.Canvas.Handle, Flags);
      finally
        Bmp.Canvas.Unlock;
      end;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  bm: TBitmap;
begin
  bm := TBitmap.Create;
  WindowSnap(Handle, bm);
  bm.PixelFormat := pf24bit;
  bm.SaveToFile('c:\screen.bmp');
  bm.Free;
end;


Как сделать скриншот клиентской области формы и сохранить его в *.bmp файл?

// В компоненте TForm уже есть метод, возвращающий
// растровое изображение клиентской области формы.
// Его описание выглядит следующим образом -
// function GetFormImage: TBitmap;

procedure TForm1.Button1Click(Sender: TObject);
var
  bm: TBitmap;
begin
  bm := TBitmap.Create;
  bm.Width := Width;
  bm.Height := Height;
  bm := GetFormImage;
  bm.SaveToFile('c:\ScreenMyForm.bmp');
  bm.Free;
end;

// Будте внимательны, поскольку данный метод не может получать
// изображения VBX компонент - на их месте будет пустое пространство.
// Это связано с различными методами реализации VCL и VBX компонент.


Как в Win9x подавить реакцию приложения на Alt+Tab, Ctrl+Alt+Del?

var
  Form1: TForm1;
  Int: LongInt;

// Отключаем Alt+Tab и Ctrl+Alt+Del
SystemParametersInfo(SPI_SCREENSAVERRUNNING, Word(True), @Int, 0);
// Включаем Alt+Tab и Ctrl+Alt+Del
SystemParametersInfo(SPI_SCREENSAVERRUNNING, Word(False), @Int, 0);

// Только для Alt-Tab: SPI_SETFASTTASKSWITCH


Как подавить реакцию приложения на Alt+F4?

// Способ первый
// Проверено в WinXP (работает) и Win7 (не работает)
type
  TForm1 = class(TForm)
  private
    procedure WMNCHitTest(var Msg: TWMNCHitTest); message WM_NCHITTEST;
    {...}
  end;

implementation

procedure TForm1.WMNCHitTest(var Msg: TWMNCHitTest);
begin
  inherited;
  with Msg do
    if Result = HTCLOSE then
      Result := HTCLIENT; {или HTNOWHERE}
end;

// Способ второй
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if ssAlt in Shift then
    if Key = VK_F4 then
      Key := 0;
end;


Как отследить переход фокуса в приложении?

// На форме должны быть компоненты,
// которые могут получать фокус

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    procedure AppControlChange(Sender: TObject);
    {...}
  end;

procedure TForm1.AppControlChange(Sender: TObject);
begin
  if Sender is TScreen then
    Caption := TScreen(Sender).ActiveForm.ActiveControl.Name;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Screen.OnActiveControlChange := AppControlChange;
end;


Как сделать, чтобы форма закрывалась при нажатии Esc?

procedure TForm1.FormCreate(Sender: TObject);
begin
  Form1.KeyPreview := True;
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_ESCAPE then 
    Close;
end;


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

// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
  DriveType: Cardinal;
  DriveChar: string;
begin
  DriveChar := ExtractFileDrive(ParamStr(0));
  DriveType := GetDriveType(PChar(DriveChar + '\'));
  case DriveType of
    DRIVE_FIXED: ShowMessage('Локальный диск ' + DriveChar + '\');
    DRIVE_REMOTE: ShowMessage('Сетевой диск ' + DriveChar + '\');
  end;
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
begin
  case Application.ExeName[1] of
    '\': ShowMessage('Программа запущена с сетевого компьютера');
  else
    ShowMessage('Программа запущена с локального компьютера');
  end;
end;

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