Округлая форма с системной тенью

Question

Я пытался сделать с SetWindowRgn, но не смог.

Может ли это сделать (верхние 2 угла закруглены, у окна есть тень), как на этой картинке?

Answer 1

Вот пример кода для установки области окна с тенью:
(Примечания: форма BorderStyle предполагается как bsNone, не может быть изменена)

type
TForm1 = class(TForm)
  procedure FormCreate(Sender: TObject);
private
  procedure CreateFlatRoundRgn;
protected
  procedure CreateParams(var Params: TCreateParams); override;
public
end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure ExcludeRectRgn(var Rgn: HRGN; LeftRect, TopRect, RightRect, BottomRect: Integer);
var
  RgnEx: HRGN;
begin
  RgnEx := CreateRectRgn(LeftRect, TopRect, RightRect, BottomRect);
  CombineRgn(Rgn, Rgn, RgnEx, RGN_OR);
  DeleteObject(RgnEx);
end;

procedure TForm1.CreateFlatRoundRgn;
const
  CORNER_SIZE = 6;
var
  Rgn: HRGN;
begin
  with BoundsRect do
  begin
    Rgn := CreateRoundRectRgn(0, 0, Right - Left + 1, Bottom - Top + 1, CORNER_SIZE, CORNER_SIZE);
    // exclude left-bottom corner
    ExcludeRectRgn(Rgn, 0, Bottom - Top - CORNER_SIZE div 2, CORNER_SIZE div 2, Bottom - Top + 1);
    // exclude right-bottom corner
    ExcludeRectRgn(Rgn, Right - Left - CORNER_SIZE div 2, Bottom - Top - CORNER_SIZE div 2, Right - Left , Bottom - Top);
  end;
  // the operating system owns the region, delete the Rgn only SetWindowRgn fails
  if SetWindowRgn(Handle, Rgn, True) = 0 then
    DeleteObject(Rgn);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  BorderStyle := bsNone;
  CreateFlatRoundRgn;
end;

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

Другой способ нарисовать собственную тень - установить Window WS_EX_LAYERED и использовать UpdateLayeredWindow

Вот очень хороший пример того, как это делается (исходники на C ++, но очень легко понять)

Для более сложных форм вы можете использовать PNG изображение в форме и Alpha Blend it.

---

EDIT:

Изменение размера WS_POPUP Окно - это мир боли ... У вас есть несколько вариантов:

• Запись обработчика WM_NCHITEST
• Используйте WM_Syscommand $F008 для изменения размера (ссылка выше) или от $F012 до для перемещения окна .
• Использование стилей WS_EX_STATICEDGE и WS_SIZEBOX.

ПРИМЕЧАНИЕ , что вам нужно заново создать область окна при ее изменении (например, OnResize событие).

Answer 2

Используйте dwm для Windows-приложения без границ. Пример кода:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
  private
    { Private declarations }
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure WndProc(var Message: TMessage); override;
  public
    { Public declarations }
  end;

  TMARGINS = record
    leftWidth: integer;
    rightWidth: integer;
    topHeight: integer;
    bottomHeight: integer;
  end;
  LPCVOID = Pointer;

  function DwmExtendFrameIntoClientArea(hWnd: HWND; const pMarInset: TMARGINS): HRESULT;
    stdcall; external 'dwmapi.dll';
  function DwmSetWindowAttribute(hWnd: HWND; dwAttribute: DWORD; pvAttribute: LPCVOID;
    cbAttribute: DWORD): HRESULT; stdcall; external 'dwmapi.dll';
  function DwmIsCompositionEnabled(out pfEnabled: BOOL): HRESULT; stdcall; external 'dwmapi.dll';

const
  CS_DROPSHADOW = $00020000;
  HTCLIENT = $1;

var
  Form1: TForm1;
  m_aeroEnabled: boolean;

implementation

{$R *.DFM}

{ TForm1 }

function CheckAeroEnabled(): boolean;
var
  Enabled: longbool;
begin
  if (Win32MajorVersion >= 6) then
  begin
    Enabled := False;
    DwmIsCompositionEnabled(Enabled);
    result := Enabled;
  end
  else
    result := False;
end;

procedure TForm1.CreateParams(var Params: TCreateParams);

begin
  inherited;
  m_aeroEnabled := CheckAeroEnabled();
  if (not m_aeroEnabled) then
    Params.WindowClass.style := Params.WindowClass.style + CS_DROPSHADOW;

end;

procedure TForm1.WndProc(var Message: TMessage);
var
  margins: TMARGINS;
  v: integer;
begin
  case (Message.Msg) of
    WM_NCPAINT: if (m_aeroEnabled) then
      begin
        v := 2;
        DwmSetWindowAttribute(Self.Handle, 2, @v, 4);

        margins.bottomHeight := 1;
        margins.leftWidth := 0;
        margins.rightWidth := 0;
        margins.topHeight := 0;

        DwmExtendFrameIntoClientArea(Self.Handle, margins);
      end;
  end;

  inherited;

  //To allow move form without Caption.
  if (Message.Msg = WM_NCHITTEST) and (Message.result = HTCLIENT) then
    Message.result := HTCAPTION;

end;

end.