Я пытался сделать с SetWindowRgn
, но не смог.
Можно сделать так (верхние 2 угла закруглены, окно имеет тень) как на этой картинке?
Я пытался сделать с SetWindowRgn
, но не смог.
Можно сделать так (верхние 2 угла закруглены, окно имеет тень) как на этой картинке?
Вот пример кода, как установить область окна с тенью:
(Примечание: предполагается, что форма 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;
Другой способ нарисовать пользовательскую тень — установить окно WS_EX_LAYERED
и использовать UpdateLayeredWindow
Вот очень хороший пример того, как это сделано (исходники на C++, но их очень легко понять)
Для более сложных форм вы можете использовать PNG
изображение в форме и Alpha Blend.
ИЗМЕНИТЬ:
Изменение размера окна WS_POPUP
— это мир боли... У вас есть несколько вариантов:
WM_Syscommand
$F008
для изменения размера (ссылка выше) или $F012
для переместить окно.WS_EX_STATICEDGE
и WS_SIZEBOX
.ПРИМЕЧАНИЕ, что вам нужно воссоздать область окна при изменении его размера (например, событие OnResize
).
Используйте 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.
BorderStyle
установлено значениеbsNone
или, например. если у вас есть форма нестандартной формы. - person TLama   schedule 13.02.2012