Jump to content
Sign in to follow this  
RDP1974

borderless with aero shadow

Recommended Posts

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.

Share this post


Link to post

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

Edited by Turan Can

Share this post


Link to post

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 by Turan Can

Share this post


Link to post

@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:

Using_DWM.png

Using_DropShadow.png

  • Like 1

Share this post


Link to post

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 😕

test_frame.jpg

Share this post


Link to post

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;

Share this post


Link to post

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 by RDP1974

Share this post


Link to post
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.

 

Share this post


Link to post
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.

image.thumb.png.60501a2f593dffcc2184691da17c282a.png

 

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.

  • Like 1

Share this post


Link to post

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
Sign in to follow this  

×