borderless with aero shadow

[RDP1974 40]

hello,

 

perhaps somebody knows how to drop the windows 10 aero shadow under a borderless vcl form?

 

I'm using from MSDN

const MARGINS shadow_on = { 0, 0, 0, 0 };

DwmExtendFrameIntoClientArea(hwnd, &shadow_on);

 

But the DWM compositor wants atleast 1px border in the frame, else don't cast the shadow.

So a line with the color of the global theme will be always visible and not accessible bcz border.

 

Btw. I don't want to use WS_LAYER_EX composited, but normal Delphi vcl form.

 

Thanks

R.

[Turan Can 3]

     if IsActive then
SystemParametersInfo(SPI_SETDROPSHADOW, 0, nil, 0);
     else
     begin
  SystemParametersInfo(SPI_SETDROPSHADOW, 0, PChar(''), 0);
     end;

Edited April 20, 2020 by Turan Can

[Turan Can 3]

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  private
    procedure CreateFlatRoundRgn;
procedure CreateParams(var Params: TCreateParams); override;
    { Private declarations }
  public
    { Public declarations }
  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 4, CORNER_SIZE div 4, Bottom - Top + 1);
    // exclude right-bottom corner
    ExcludeRectRgn(Rgn, Right - Left - CORNER_SIZE div 4, Bottom - Top - CORNER_SIZE div 4, 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.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;

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

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    ReleaseCapture;
    SendMessage(Self.Handle, WM_SYSCOMMAND, SC_MOVE + HTCAPTION, 0);
  end;
end;

end.
 

Edited April 20, 2020 by Turan Can

[vfbb 285]

@RDP1974, @Turan Can

To get a beatiful shadow, use the DWM API.

 

Shadow in borderless form in VCL:

unit Unit3;

interface

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

type
  TForm3 = class(TForm)
  private
    { Private declarations }
    function SetBordelessShadow: Boolean;
  protected
    procedure CreateParams(var AParams: TCreateParams); override;
    procedure CreateWindowHandle(const AParams: TCreateParams); override;
    procedure WndProc(var AMessage: TMessage); override;
  public
    { Public declarations }
  end;

var
  Form3: TForm3;

implementation

uses
  Winapi.DwmApi, Winapi.UxTheme;

{$R *.dfm}

{ TForm3 }

procedure TForm3.CreateParams(var AParams: TCreateParams);
begin
  inherited CreateParams(AParams);
  if TOSVersion.Major < 6 then
  begin
    AParams.Style := WS_POPUP;
    AParams.WindowClass.Style := AParams.WindowClass.Style or CS_DROPSHADOW;
  end;
end;

procedure TForm3.CreateWindowHandle(const AParams: TCreateParams);
begin
  inherited;
  if TOSVersion.Major >= 6 then
    SetBordelessShadow;
end;

function TForm3.SetBordelessShadow: Boolean;
var
  LMargins: TMargins;
  LPolicy: Integer;
begin
  if TOSVersion.Major < 6 then
    Exit(False);
  LPolicy := DWMNCRP_ENABLED;
  Result := Succeeded(DwmSetWindowAttribute(Handle, DWMWA_NCRENDERING_POLICY, @LPolicy, SizeOf(Integer))) and DwmCompositionEnabled;
  if Result then
  begin
    LMargins.cxLeftWidth := 1;
    LMargins.cxRightWidth := 1;
    LMargins.cyTopHeight := 1;
    LMargins.cyBottomHeight := 1;
    Result := Succeeded(DwmExtendFrameIntoClientArea(Handle, LMargins));
  end;
end;

procedure TForm3.WndProc(var AMessage: TMessage);
begin
  case AMessage.Msg of
    WM_DWMCOMPOSITIONCHANGED,
    WM_DWMNCRENDERINGCHANGED:
      if SetBordelessShadow then
      begin
        AMessage.Result := 0;
        Exit;
      end;
  else
  end;
  inherited;
end;

end.

Note: You can do the same in FMX!

See the difference in the images attached:

[RDP1974 40]

thank you, but the problem is the 1px frame of the color of theme title

I have read a C++ example that I will try in Delphi, needs a return parameter from paint API where VCL use a procedure without return 😕

[Turan Can 3]

procedure TfmBar1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  OnBaseMove(Button, Self.Handle);
end;

procedure TfmBar1.FormPaint(Sender: TObject);
begin
  OnBasePaint(ClientWidth, ClientHeight, Canvas);
end;

procedure TfmBar1.FormShow(Sender: TObject);
begin
  FClSys.OnMenuEvent := MenuEvent;
  BorderStyle := bsNone;

end;

procedure TfmBar1.OnBaseMove(Button: TMouseButton; Handle: HWND);
begin
  if Button = mbLeft then
  begin
    ReleaseCapture;
    SendMessage(Handle, WM_SYSCOMMAND, SC_MOVE + HTCAPTION, 0);
  end;
end;

procedure TfmBar1.OnBasePaint(ClientWidth, ClientHeight: Integer; Canvas: TCanvas);
var
  Rect: TRect;
begin
  Rect.Left := 0;
  Rect.Top := 0;
  Rect.Bottom := ClientHeight;
  Rect.Right := ClientWidth;
  with Canvas do
  begin
    Pen.Width := 1;
     Brush.Color := $00000000;
    Pen.Color := $006B6B6B;
    Rectangle(0, 0, ClientWidth, ClientHeight);
  end;
end;

[RDP1974 40]

No, the canvas is inside the external frame.

 

The solution in plain API is here:

https://stackoverflow.com/questions/22165258/how-to-create-window-without-border-and-with-shadow-like-github-app/44489430#44489430

 

1. Create window with WS_CAPTION style
2. Call DwmExtendFrameIntoClientArea WDM API passing 1 pixel top margin
3. Handle WM_NCCALCSIZE message, do not forward call to DefWindowProc while processing this message, but just return 0

 

(https://stackoverflow.com/questions/43818022/borderless-window-with-drop-shadow)

Edited April 21, 2020 by RDP1974

[vfbb 285]

36 minutes ago, RDP1974 said:

No, the canvas is inside the external frame.

 

The solution in plain API is here:

https://stackoverflow.com/questions/22165258/how-to-create-window-without-border-and-with-shadow-like-github-app/44489430#44489430

 

1. Create window with WS_CAPTION style
2. Call DwmExtendFrameIntoClientArea WDM API passing 1 pixel top margin
3. Handle WM_NCCALCSIZE message, do not forward call to DefWindowProc while processing this message, but just return 0

 

(https://stackoverflow.com/questions/43818022/borderless-window-with-drop-shadow)

Roberto, now I undestand your question, but this solution not work for me.

I don't know why this line is there, but if it helps you, the same is not happening in FMX applications. The possible solution may be in the units FMX.Platform.Win or FMX.Forms.Border.Win.

 

[RDP1974 40]

I know, but I need VCL 🙂

[vhanla 2]

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    procedure WMNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE;
  public
    { Public declarations }
  end;
var
  Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
  // to hide white 1px line in top
  DoubleBuffered := True;
  Panel1.Align := alClient;
  Panel1.BevelOuter := TBevelCut.bvNone;
  Panel1.Caption := '';
  // enable DWMApi Shadow
  GlassFrame.Top := 1;
  GlassFrame.Enabled := True;
end;
procedure TForm1.WMNCCalcSize(var Msg: TWMNCCalcSize);
begin
  // to hide caption bar
  Msg.Msg := WM_NULL;
  inherited;
end;

I was playing with this in Windows 10/Rio. I don't know if on other versions requires more adjustments (I guess so), but this was short code to achieve that.

 

And it keeps system context menu, aero snap response too. I tried painting canvas to remove the 1 pixel white line at the top, no success, but `doublebuffered` set to true along a component occupying that part was enough.