Is there a way to round Delphi VCL Form without losing native windows borders

Question

I have this repo here DelphiUCL

It's very nice Lib which allow bsSisezable form looks like UWP Forms and What caught my attention is when I resize this form it still resizes as bsResizable Form and not like bsNone Form

What I need to know exactly: Is there a way to create a Smooth Round Corners Delphi VCL Form without losing the native windows borders?

Answer 1

I have a workaround but I don't know if it will fit your need. The workaround consist of defining a rounded rectangle region to clip the window to remove title bar and border. This way, the windows is a rounded rectangle.

Then, to get back the title bar and border, you have - for example - to detect if the mouse is near one of the edges and if it is, delete the region so that title bar and borders are again visible and can be used.

All that involve handling a few messages.

Here is the code:

unit RegionDemoMain;

interface

uses
    Winapi.Windows, Winapi.Messages,
    System.SysUtils, System.Variants, System.Classes,
    Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;

type
    TRoundedForm = class(TForm)
        CloseButton: TButton;
        HelpLabel: TLabel;
        procedure FormCreate(Sender: TObject);
        procedure CloseButtonClick(Sender: TObject);
        procedure WMMouseMove(var Msg : TWMMouseMove); message WM_MOUSEMOVE;
        procedure WMNCMouseLeave(var Msg : TMessage); message WM_NCMOUSELEAVE;
        procedure WMNCButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN;
        procedure WMNCButtonUp(var Msg : TWMNCLButtonUp); message WM_NCLBUTTONUP;
        procedure WMSYSCommand(var Msg : TWMSysCommand); message WM_SYSCOMMAND;
    private
        FRgnHandle       : HRGN;
        FRgnTop          : Integer;
        FRgnBottom       : Integer;
        FRgnRight        : Integer;
        FRgnLeft         : Integer;
        FRgnCorner       : Integer;
        FMouseLeaveCount : Integer;
        FNCLButtonDown   : Boolean;
        procedure DeleteRegion;
        procedure CreateRegion;
    end;

var
  RoundedForm: TRoundedForm;

implementation

{$R *.dfm}

procedure TRoundedForm.FormCreate(Sender: TObject);
begin
    FRgnTop    := GetSystemMetrics(SM_CYCAPTION) +
                  GetSystemMetrics(SM_CYFRAME) +
                  GetSystemMetrics(SM_CYFRAME); 
    FRgnBottom := GetSystemMetrics(SM_CYFRAME) +
                  GetSystemMetrics(SM_CYFRAME);
    FRgnRight  := GetSystemMetrics(SM_CXFRAME) +
                  GetSystemMetrics(SM_CXFRAME);
    FRgnLeft   := GetSystemMetrics(SM_CXFRAME) +
                  GetSystemMetrics(SM_CXFRAME);
    FRgnCorner := 15;
    CreateRegion;
end;

procedure TRoundedForm.CreateRegion;
begin
    if FRgnHandle <> 0 then
        DeleteObject(FRgnHandle);
    FRgnHandle := CreateRoundRectRgn(FRgnLeft,
                                     FRgnTop,
                                     Width  - FRgnRight,
                                     Height - FRgnBottom,
                                     FRgnCorner,
                                     FRgnCorner);
    SetWindowRGN(Handle, FRgnHandle, True);
end;

procedure TRoundedForm.CloseButtonClick(Sender: TObject);
begin
    Close;
end;

procedure TRoundedForm.DeleteRegion;
begin
    if FRgnHandle <> 0 then begin
        SetWindowRGN(Handle, 0, True);
        DeleteObject(FRgnHandle);
        FRgnHandle := 0;
    end;
end;

procedure TRoundedForm.WMMouseMove(var Msg: TWMMouseMove);
begin
    if (Msg.YPos < GetSystemMetrics(SM_CYSIZEFRAME)) or
       (Msg.YPos > (Height - 55)) or
       (Msg.XPos < 10) or
       (Msg.XPos > (Width - 25)) then
        DeleteRegion
    else if (FRgnHandle = 0) and (Msg.YPos > 10) then
        CreateRegion;
    inherited;
end;

procedure TRoundedForm.WMNCButtonDown(var Msg: TWMNCLButtonDown);
begin
    FNCLButtonDown := TRUE;
    inherited;
end;

procedure TRoundedForm.WMNCButtonUp(var Msg: TWMNCLButtonUp);
begin
    FNCLButtonDown := FALSE;
    inherited;
end;

procedure TRoundedForm.WMNCMouseLeave(var Msg : TMessage);
begin
    Inc(FMouseLeaveCount);
    if (FRgnHandle = 0) and (not FNCLButtonDown) then
        CreateRegion;
    inherited;
end;

procedure TRoundedForm.WMSYSCommand(var Msg: TWMSysCommand);
begin
    if Msg.CmdType = SC_RESTORE then
        CreateRegion;
    inherited;
end;

end.

and DFM file:

object RoundedForm: TRoundedForm
  Left = 0
  Top = 0
  Caption = 'RoundedForm'
  ClientHeight = 299
  ClientWidth = 635
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object HelpLabel: TLabel
    Left = 200
    Top = 96
    Width = 222
    Height = 13
    Caption = 'Move the cursor near one edge of the window'
  end
  object CloseButton: TButton
    Left = 268
    Top = 132
    Width = 75
    Height = 25
    Caption = 'CloseButton'
    TabOrder = 0
    OnClick = CloseButtonClick
  end
end