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

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

:: Меню ::

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

:: FAQ ::

:: Заметки ::

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

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

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

:: MVP ::

:: RSS ::

Как переключить окна в полноэкранный режим и обратно?


procedure TForm1.Button1Click(Sender: TObject);
var
  WndStyle: NativeInt;
begin
  WndStyle := GetWindowLong(Handle, GWL_STYLE);
  if WndStyle and WS_OVERLAPPEDWINDOW = WS_OVERLAPPEDWINDOW then
  begin
    SetWindowLong(Handle, GWL_STYLE, WndStyle and not WS_OVERLAPPEDWINDOW);
    ShowWindow(Handle, SW_MAXIMIZE);
  end
  else
  begin
    SetWindowLong(Handle, GWL_STYLE, WndStyle or WS_OVERLAPPEDWINDOW);
    ShowWindow(Handle, SW_RESTORE);
  end;
end;

Как прочитать заголовок EXE файла?


procedure DumpDOSHeader(const h: IMAGE_DOS_HEADER; Lines: TStrings);
begin
  Lines.Add('Dump of DOS file header');
  Lines.Add(Format('Magic number: %d', [h.e_magic]));
  Lines.Add(Format('Bytes on last page of file: %d', [h.e_cblp]));
  Lines.Add(Format('Pages in file: %d', [h.e_cp]));
  Lines.Add(Format('Relocations: %d', [h.e_crlc]));
  Lines.Add(Format('Size of header in paragraphs: %d', [h.e_cparhdr]));
  Lines.Add(Format('Minimum extra paragraphs needed: %d', [h.e_minalloc]));
  Lines.Add(Format('Maximum extra paragraphs needed: %d', [h.e_maxalloc]));
  Lines.Add(Format('Initial (relative) SS value: %d', [h.e_ss]));
  Lines.Add(Format('Initial SP value: %d', [h.e_sp]));
  Lines.Add(Format('Checksum: %d', [h.e_csum]));
  Lines.Add(Format('Initial IP value: %d', [h.e_ip]));
  Lines.Add(Format('Initial (relative) CS value: %d', [h.e_cs]));
  Lines.Add(Format('File address of relocation table: %d', [h.e_lfarlc]));
  Lines.Add(Format('Overlay number: %d', [h.e_ovno]));
  Lines.Add(Format('OEM identifier (for e_oeminfo): %d', [h.e_oemid]));
  Lines.Add(Format('OEM information; e_oemid specific: %d', [h.e_oeminfo]));
  Lines.Add(Format('File address of new exe header: %d', [h._lfanew]));
  Lines.Add('');
end;

procedure DumpPEHeader(const h: IMAGE_FILE_HEADER; Lines: TStrings);
var
  dt: TDateTime;
begin
  Lines.Add('Dump of PE file header');
  Lines.Add(Format('Machine: %4x', [h.Machine]));
  case h.Machine of
    IMAGE_FILE_MACHINE_UNKNOWN: Lines.Add(' MACHINE_UNKNOWN');
    IMAGE_FILE_MACHINE_I386: Lines.Add(' Intel 386.');
    IMAGE_FILE_MACHINE_R3000: Lines.Add(' MIPS little-endian, 0x160 big-endian');
    IMAGE_FILE_MACHINE_R4000: Lines.Add(' MIPS little-endian');
    IMAGE_FILE_MACHINE_R10000: Lines.Add(' MIPS little-endian');
    IMAGE_FILE_MACHINE_ALPHA: Lines.Add(' Alpha_AXP');
    IMAGE_FILE_MACHINE_POWERPC: Lines.Add(' IBM PowerPC Little-Endian');
    // some values no longer defined in winnt.h
    $14D: Lines.Add(' Intel i860');
    $268: Lines.Add(' Motorola 68000');
    $290: Lines.Add(' PA RISC');
  else
    Lines.Add(' unknown machine type');
  end; { Case }
  Lines.Add(Format('NumberOfSections: %d', [h.NumberOfSections]));
  Lines.Add(Format('TimeDateStamp: %d', [h.TimeDateStamp]));
  dt := EncodeDate(1970, 1, 1) + h.TimeDateStamp / SecsPerDay; // GMT
  Lines.Add(FormatDateTime(' c', dt));

  Lines.Add(Format('PointerToSymbolTable: %d', [h.PointerToSymbolTable]));
  Lines.Add(Format('NumberOfSymbols: %d', [h.NumberOfSymbols]));
  Lines.Add(Format('SizeOfOptionalHeader: %d', [h.SizeOfOptionalHeader]));
  Lines.Add(Format('Characteristics: %d', [h.Characteristics]));
  if IMAGE_FILE_DLL and h.Characteristics <> 0 then
    Lines.Add(' file is a DLL')
  else if IMAGE_FILE_EXECUTABLE_IMAGE and h.Characteristics <> 0 then
    Lines.Add(' file is a program');
  Lines.Add('');
end;

procedure DumpOptionalHeader(const h: IMAGE_OPTIONAL_HEADER; Lines: TStrings);
begin
  Lines.Add('Dump of PE optional file header');
  Lines.Add(Format('Magic: %d', [h.Magic]));
  case h.Magic of
    $107: Lines.Add(' ROM image');
    $10B: Lines.Add(' executable image');
  else
    Lines.Add(' unknown image type');
  end;
  Lines.Add(Format('MajorLinkerVersion: %d', [h.MajorLinkerVersion]));
  Lines.Add(Format('MinorLinkerVersion: %d', [h.MinorLinkerVersion]));
  Lines.Add(Format('SizeOfCode: %d', [h.SizeOfCode]));
  Lines.Add(Format('SizeOfInitializedData: %d', [h.SizeOfInitializedData]));
  Lines.Add(Format('SizeOfUninitializedData: %d', [h.SizeOfUninitializedData]));
  Lines.Add(Format('AddressOfEntryPoint: %d', [h.AddressOfEntryPoint]));
  Lines.Add(Format('BaseOfCode: %d', [h.BaseOfCode]));
  Lines.Add(Format('BaseOfData: %d', [h.BaseOfData]));
  Lines.Add(Format('ImageBase: %d', [h.ImageBase]));
  Lines.Add(Format('SectionAlignment: %d', [h.SectionAlignment]));
  Lines.Add(Format('FileAlignment: %d', [h.FileAlignment]));
  Lines.Add(Format('MajorOperatingSystemVersion: %d', [h.MajorOperatingSystemVersion]));
  Lines.Add(Format('MinorOperatingSystemVersion: %d', [h.MinorOperatingSystemVersion]));
  Lines.Add(Format('MajorImageVersion: %d', [h.MajorImageVersion]));
  Lines.Add(Format('MinorImageVersion: %d', [h.MinorImageVersion]));
  Lines.Add(Format('MajorSubsystemVersion: %d', [h.MajorSubsystemVersion]));
  Lines.Add(Format('MinorSubsystemVersion: %d', [h.MinorSubsystemVersion]));
  Lines.Add(Format('Win32VersionValue: %d', [h.Win32VersionValue]));
  Lines.Add(Format('SizeOfImage: %d', [h.SizeOfImage]));
  Lines.Add(Format('SizeOfHeaders: %d', [h.SizeOfHeaders]));
  Lines.Add(Format('CheckSum: %d', [h.CheckSum]));
  Lines.Add(Format('Subsystem: %d', [h.Subsystem]));
  case h.Subsystem of
    IMAGE_SUBSYSTEM_NATIVE: Lines.Add(' Image doesnot require a subsystem.');
    IMAGE_SUBSYSTEM_WINDOWS_GUI: Lines.Add(' Image runs in the Windows GUI subsystem.');
    IMAGE_SUBSYSTEM_WINDOWS_CUI: Lines.Add(' Image runs in the Windows character subsystem.');
    IMAGE_SUBSYSTEM_OS2_CUI: Lines.Add(' image runs in the OS/2 character subsystem.');
    IMAGE_SUBSYSTEM_POSIX_CUI: Lines.Add(' image run in the Posix character subsystem.');
  else
    Lines.Add(' unknown subsystem')
  end;
  Lines.Add(Format('DllCharacteristics: %d', [h.DllCharacteristics]));
  Lines.Add(Format('SizeOfStackReserve: %d', [h.SizeOfStackReserve]));
  Lines.Add(Format('SizeOfStackCommit: %d', [h.SizeOfStackCommit]));
  Lines.Add(Format('SizeOfHeapReserve: %d', [h.SizeOfHeapReserve]));
  Lines.Add(Format('SizeOfHeapCommit: %d', [h.SizeOfHeapCommit]));
  Lines.Add(Format('LoaderFlags: %d', [h.LoaderFlags]));
  Lines.Add(Format('NumberOfRvaAndSizes: %d', [h.NumberOfRvaAndSizes]));
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  fs: TFilestream;
  signature: DWORD;
  dos_header: IMAGE_DOS_HEADER;
  pe_header: IMAGE_FILE_HEADER;
  opt_header: IMAGE_OPTIONAL_HEADER;
begin
  Memo1.Clear;

  fs := TFilestream.Create(ParamStr(0), fmOpenread or fmShareDenyNone);
  try
    fs.Read(dos_header, SizeOf(dos_header));
    if dos_header.e_magic <> IMAGE_DOS_SIGNATURE then
    begin
      Memo1.Lines.Add('Invalid DOS file header');
      Exit;
    end;
    DumpDOSHeader(dos_header, Memo1.Lines);

    fs.Seek(dos_header._lfanew, soFromBeginning);
    fs.Read(signature, SizeOf(signature));
    if signature <> IMAGE_NT_SIGNATURE then
    begin
      Memo1.Lines.Add('Invalid PE header');
      Exit;
    end;

    fs.Read(pe_header, SizeOf(pe_header));
    DumpPEHeader(pe_header, Memo1.Lines);

    if pe_header.SizeOfOptionalHeader > 0 then
    begin
      fs.Read(opt_header, SizeOf(opt_header));
      DumpOptionalHeader(opt_header, Memo1.Lines);
    end;
  finally
    fs.Free;
  end;
end;

Как защитить приложение от снятия скриншота?


procedure TForm1.FormCreate(Sender: TObject);
begin
  // Функция SetWindowDisplayAffinity защищает от скриншота только в том
  // случае, когда в системе активен Desktop Window Manager, который
  // используется в графическом интерфейсе Windows Aero. В базовых и
  // упрощенных схемах скриншоты делаются как обычно без каких-либо
  // ограничений. Для отмены защиты окна, надо повторно вызвать функцию
  // с параметром WDA_NONE.
  SetWindowDisplayAffinity(Handle, WDA_MONITOR);
end;

Как получить информацию о заголовке окна?


procedure TForm1.Button1Click(Sender: TObject);
const
  _TitleBar = 0;
  _Reserved1 = 1;
  _Minimize = 2;
  _Maximize = 3;
  _Help = 4;
  _Close = 5;

  State = STATE_SYSTEM_INVISIBLE or
          STATE_SYSTEM_OFFSCREEN or
          STATE_SYSTEM_UNAVAILABLE;
var
  tbi: TTitleBarInfoEx;
begin
  tbi.cbSize := SizeOf(TTitleBarInfoEx);
  SendMessage(Handle, WM_GETTITLEBARINFOEX, 0, LParam(@tbi));

  // Если кнопка доступна, показываем ее координаты
  if tbi.rgstate[_Close] and State = 0 then
  ShowMessage(
    Format('Left: %d; Top: %d', [tbi.rgrect[_Close].Left, tbi.rgrect[_Close].Top])
  );
end;

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


procedure TForm1.Button1Click(Sender: TObject);
begin
  // Работает в случае, если форма была открыта вызовом метода ShowModal
  if fsModal in FormState then
    ShowMessage('Форма открыта в модальном режиме');
end;

Как не дать форме закрыться?


// Способ первый
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caNone;
end;

// Способ второй
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  CanClose := False;
end;

// Способ третий
// Работает для главной формы проекта за счет того,
// что процедура Close имеет следующий код:
// procedure TCustomForm.Close;
// {...}
// begin
//   if fsModal in FFormState then
//     ModalResult := mrCancel
//   {...}
procedure TForm1.Button1Click(Sender: TObject);
begin
  FFormState := FFormState + [fsModal];
end;

Как изменять размер формы с дискретным шагом?


type
  TForm1 = class(TForm)
  private
    procedure WmSizing(var Msg: TMessage); message WM_SIZING;
    {...}
  end;

implementation

procedure TForm1.WMSizing(var Msg: TMessage);
const
  STEP = 32;
var
  Side: LongInt;
  Rect: PRect;
begin
  inherited;
  Side := Msg.WParam;
  Rect := PRect(Msg.LParam);

  if WMSZ_BOTTOM and Side = WMSZ_BOTTOM then
    Rect^.Bottom := Rect^.Bottom - (Rect^.Bottom mod STEP);
  if WMSZ_BOTTOMLEFT and Side = WMSZ_BOTTOMLEFT then
  begin
    Rect^.Bottom := Rect^.Bottom - (Rect^.Bottom mod STEP);
    Rect^.Left := Rect^.Left - (Rect^.Left mod STEP);
  end;
  if WMSZ_BOTTOMRIGHT and Side = WMSZ_BOTTOMRIGHT then
  begin
    Rect^.Bottom := Rect^.Bottom - (Rect^.Bottom mod STEP);
    Rect^.Right := Rect^.Right - (Rect^.Right mod STEP);
  end;
  if WMSZ_LEFT and Side = WMSZ_LEFT then
    Rect^.Left := Rect^.Left - (Rect^.Left mod STEP);
  if WMSZ_RIGHT and Side = WMSZ_RIGHT then
    Rect^.Right := Rect^.Right - (Rect^.Right mod STEP);
  if WMSZ_TOP and Side = WMSZ_TOP then
    Rect^.Top := Rect^.Top - (Rect^.Top mod STEP);
  if WMSZ_TOPLEFT and Side = WMSZ_TOPLEFT then
  begin
    Rect^.Top := Rect^.Top - (Rect^.Top mod STEP);
    Rect^.Left := Rect^.Left - (Rect^.Left mod STEP);
  end;
  if WMSZ_TOPRIGHT and Side = WMSZ_TOPRIGHT then
  begin
    Rect^.Top := Rect^.Top - (Rect^.Top mod STEP);
    Rect^.Right := Rect^.Right - (Rect^.Right mod STEP);
  end;

  Msg.Result := 1;
end;

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


type
  TForm1 = class(TForm)
    cbAlphaBlendOnClick: TCheckBox; // Прозрачночть при клике по заголовку
    cbAlphaBlendOnMove: TCheckBox;  // Прозрачночть при перемещении
    procedure FormCreate(Sender: TObject);
  private
    procedure WMNCLButtonDown(var Msg: TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
    procedure WMNExitSizeMove(var Msg: TMessage); message WM_EXITSIZEMOVE;
    procedure WMMove(var Msg: TWMMove); message WM_MOVE;
    {...}
  end;

implementation

procedure TForm1.FormCreate(Sender: TObject);
begin
  AlphaBlendValue := 180;
end;

procedure TForm1.WMNCLButtonDown(var Msg: TWMNCLButtonDown);
begin
  if Msg.HitTest = HTCAPTION then
  begin
    AlphaBlend := cbAlphaBlendOnClick.Checked;
    inherited;
    if AlphaBlend then
      AlphaBlend := False;
  end
  else
    inherited;
end;

procedure TForm1.WMMove(var Msg: TWMMove);
begin
  inherited;
  AlphaBlend := cbAlphaBlendOnMove.Checked;
end;

procedure TForm1.WMNExitSizeMove(var Msg: TMessage);
begin
  AlphaBlend := False;
  inherited;
end;

Как изменить форму окна по картинке?


// Способ первый
// На основе BMP без прозрачности
type
  TForm1 = class(TForm)
    Image1: TImage;
    procedure FormCreate(Sender: TObject);
    {...}
  end;

implementation

procedure TForm1.FormCreate(Sender: TObject);
var
  regn, tmpRegn: Integer; // регион окна и временный регион
  x, y: Integer; // координаты пикселя
  nullClr: TColor; // «прозрачный цвет»
begin
  BorderStyle := bsNone;
  ClientWidth := Image1.Picture.Bitmap.Width;
  ClientHeight := Image1.Picture.Bitmap.Height;

  with Image1.Picture do
  begin
    nullClr := Bitmap.Canvas.Pixels[0, 0];
    regn := CreateRectRgn(0, 0, Graphic.Width, Graphic.Height);
    for x := 1 to Graphic.Width do
      for y := 1 to Graphic.Height do
        if Bitmap.Canvas.Pixels[x-1, y-1] = nullClr then
        begin
          tmpRegn := CreateRectRgn(x-1, y-1, x, y);
          CombineRgn(regn, regn, tmpRegn, RGN_DIFF);
          DeleteObject(tmpRegn);
        end;
  end;
  SetWindowRgn(Form1.handle, regn, True);
end;

// Способ второй
// На основе PNG с прозрачностью
type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    hBmp: HBITMAP;
    BackDC: HDC;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  Winapi.GDIPOBJ, Winapi.GDIPAPI;

procedure TForm1.FormCreate(Sender: TObject);
var
  Img: TGPBitmap;
  ScreenDC: HDC;
  pt1, pt2: TPoint;
  sz: TSize;
  bf: TBlendFunction;
begin
  BorderStyle := bsNone;

  if SetWindowLong(Handle, GWL_EXSTYLE,
    GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED) = 0 then
    ShowMessage(SysErrorMessage(GetLastError));

  Img := TGPBitmap.Create('c:\Backrgound.png', True);

  with Img do
  begin
    GetHBITMAP(0, hBmp);
    Width := GetWidth;
    Height := GetHeight;
    Free;
  end;

  ScreenDC := GetDC(0); // Берем контекст рабочего стола
  BackDC := CreateCompatibleDC(ScreenDC); // Создаем временный контекст
  SelectObject(BackDC, hBmp); // Применяем к нему наш битмап
  pt1 := Point(Left, Top);
  pt2 := Point(0, 0);
  sz.cx := Width;
  sz.cy := Height;

  with bf do
  begin
    BlendOp := AC_SRC_OVER;
    BlendFlags := 0;
    SourceConstantAlpha := $FF;
    AlphaFormat := AC_SRC_ALPHA;
  end;

  UpdateLayeredWindow(Handle, ScreenDC, @pt1,
    @sz, BackDC, @pt2, 0, @bf, ULW_ALPHA);

  ReleaseDC(0, ScreenDC);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  DeleteObject(hBmp);
  DeleteDC(BackDC);
end;

Как определить разрядность exe/dll?


// Способ первый
// Подходит только для exe
procedure TForm1.Button1Click(Sender: TObject);
var
  BinaryType: Cardinal;
  FileName, Msg: string;
begin
  FileName := 'c:\test.exe';

  GetBinaryType(PChar(FileName), BinaryType);
  case BinaryType of
    SCS_32BIT_BINARY: ShowMessage('A 32-bit Windows-based application');
    SCS_WOW_BINARY: ShowMessage('A 16-bit Windows-based application');
    SCS_PIF_BINARY: ShowMessage('A PIF file that executes an MS-DOS – based application');
    SCS_POSIX_BINARY: ShowMessage('A POSIX – based application');
    SCS_OS216_BINARY: ShowMessage('A 16-bit OS/2-based application');
    SCS_64BIT_BINARY: ShowMessage('A 64-bit Windows-based application');
  else
    Msg := SysErrorMessage(GetLastError);
    Msg := StringReplace(Msg, '%1', '%s', []);
    ShowMessage(Format(Msg, [ExtractFileName(FileName)]));
  end;
end;

// Способ второй
// Подходит и для exe, и для dll
procedure TForm1.Button1Click(Sender: TObject);
var
  fs: TFilestream;
  signature: DWORD;
  dos_header: IMAGE_DOS_HEADER;
  pe_header: IMAGE_FILE_HEADER;

  FileName: string;
begin
  FileName := 'c:\test.dll';

  fs := TFilestream.Create(FileName, fmOpenread or fmShareDenyNone);
  try
    fs.Read(dos_header, SizeOf(dos_header));
    if dos_header.e_magic <> IMAGE_DOS_SIGNATURE then
      Exit;

    fs.Seek(dos_header._lfanew, soFromBeginning);
    fs.Read(signature, SizeOf(signature));
    if signature <> IMAGE_NT_SIGNATURE then
      Exit;

    fs.Read(pe_header, SizeOf(pe_header));
    case pe_header.Machine of
      IMAGE_FILE_MACHINE_I386: ShowMessage('x32');
      IMAGE_FILE_MACHINE_AMD64,
      IMAGE_FILE_MACHINE_IA64: ShowMessage('x64');
    end;
  finally
    fs.Free;
  end;
end;

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