¿Cómo dibujar un control sobre un formulario WS_EX_LAYERED?

Question

Estoy usando este código, dibuje una forma transparente de un color sólido.

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) 
    Button1: TButton; 
    procedure FormCreate(Sender: TObject); 
    private 
    { Private declarations } 
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST; 
    public 
    { Public declarations } 
    end; 

var 
    Form1: TForm1; 

implementation 

{$R *.dfm} 

procedure TForm1.FormCreate(Sender: TObject); 
var 
    BlendFunction: TBlendFunction; 
    BitmapPos: TPoint; 
    BitmapSize: TSize; 
    exStyle: DWORD; 
    Bitmap: TBitmap; 
begin 
    exStyle := GetWindowLongA(Handle, GWL_EXSTYLE); 
    if (exStyle and WS_EX_LAYERED = 0) then 
    SetWindowLong(Handle, GWL_EXSTYLE, exStyle or WS_EX_LAYERED); 

    Bitmap := TBitmap.Create; 
    try 
    Bitmap.PixelFormat := pf32bit; 
    Bitmap.SetSize(Width, Height); 
    Bitmap.Canvas.Brush.Color:=clRed; 
    Bitmap.Canvas.FillRect(Rect(0,0, Bitmap.Width, Bitmap.Height)); 
    BitmapPos := Point(0, 0); 
    BitmapSize.cx := Bitmap.Width; 
    BitmapSize.cy := Bitmap.Height; 
    BlendFunction.BlendOp := AC_SRC_OVER; 
    BlendFunction.BlendFlags := 0; 
    BlendFunction.SourceConstantAlpha := 150; 
    BlendFunction.AlphaFormat := 0; 

    UpdateLayeredWindow(Handle, 0, nil, @BitmapSize, Bitmap.Canvas.Handle, 
     @BitmapPos, 0, @BlendFunction, ULW_ALPHA); 

    Show; 
    finally 
    Bitmap.Free; 
    end; 
end; 

procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest); 
begin 
    Message.Result := HTCAPTION; 
end; 

end. 

Pero ninguno de los controles aparece en la forma, ya que leí esta pregunta UpdateLayeredWindow with normal canvas/textout pero utilizando SetLayeredWindowAttributes (como la respuesta aceptada sugerir) con LWA_COLORKEY o LWA_ALPHA no está funcionando.

Es posible dibujar un control (TButton, TEdit) en una forma estratificada que utiliza la función UpdateLayeredWindow?

Answer 1

La documentación que he denegado en el comentario de la pregunta es un poco oscura. La siguiente cita de Using Layered Windows (msdn) es mucho más explícita en que, , si va a utilizar UpdateLayeredWindows, no podrá utilizar el marco de pintura incorporado suministrado por VCL. La implicación es que, solo verás lo que dibujaste en el mapa de bits.

Para utilizar UpdateLayeredWindow, los bits visuales para una ventana de capas tienen que ser prestados en un mapa de bits compatible. Luego, a través de un Contexto de dispositivo GDI compatible, se proporciona el mapa de bits a la API UpdateLayeredWindow, junto con la información deseada de color-key y alpha-blend. El mapa de bits también puede contener información alfa por píxel.

Tenga en cuenta que cuando se utiliza UpdateLayeredWindow la aplicación no tiene que responder a WM_PAINT u otros mensajes pintura, porque ya ha proporcionado la representación visual de la ventana y el sistema se encargará de almacenar esa imagen, componiéndolo y mostrándolo en la pantalla. UpdateLayeredWindow es bastante potente, pero a menudo requiere modificar la forma en que se dibuja una aplicación Win32 existente.

siguiente código es un intento de demostrar cómo se puede hacer que el VCL preprocese el mapa de bits para usted utilizando el método de la forma PaintTo, antes de aplicar sus efectos visuales ((no es que yo' sugiriendo el uso de este método, simplemente tratando de mostrar lo que llevaría a ...). También tenga en cuenta que, si todo lo que va a hacer es "hacer un color sólido semitransparente", TLama sugerencia en los comentarios a la pregunta es el camino a seguir.

He puesto el código en un WM_PRINTCLIENT para tener un en vivo forma. Sin embargo, esto es un poco inútil, porque no todas las acciones que requieren una indicación visual activarán un 'WM_PRINTCLIENT'. Por ejemplo, en el siguiente proyecto, hacer clic en el botón o en la casilla de verificación se reflejará en la apariencia del formulario, pero escribir en la nota no lo hará.

type 
    TForm1 = class(TForm) 
    Button1: TButton; 
    Memo1: TMemo; 
    CheckBox1: TCheckBox; 
    Label1: TLabel; 
    procedure FormCreate(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    protected 
    procedure WMPrintClient(var Msg: TWMPrintClient); message WM_PRINTCLIENT; 
    private 
    FBitmap: TBitmap; 
    end; 

var 
    Form1: TForm1; 

implementation 

{$R *.dfm} 

const 
    Alpha = $D0; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
    FBitmap := TBitmap.Create; 
    FBitmap.PixelFormat := pf32bit; 
    FBitmap.SetSize(Width, Height); 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
    FBitmap.Free; 
end; 


procedure TForm1.WMPrintClient(var Msg: TWMPrintClient); 
var 
    exStyle: DWORD; 
    ClientOrg: TPoint; 
    X, Y: Integer; 
    Pixel: PRGBQuad; 
    BlendFunction: TBlendFunction; 
    BitmapPos: TPoint; 
    BitmapSize: TSize; 
begin 
    exStyle := GetWindowLongA(Handle, GWL_EXSTYLE); 
    if (exStyle and WS_EX_LAYERED = 0) then 
    SetWindowLong(Handle, GWL_EXSTYLE, exStyle or WS_EX_LAYERED); 

    // for non-client araea only 
    FBitmap.Canvas.Brush.Color := clBtnShadow; 
    FBitmap.Canvas.FillRect(Rect(0,0, FBitmap.Width, FBitmap.Height)); 

    // paste the client image 
    ClientOrg.X := ClientOrigin.X - Left; 
    ClientOrg.Y := ClientOrigin.Y - Top; 
    FBitmap.Canvas.Lock; 
    PaintTo(FBitmap.Canvas.Handle, ClientOrg.X, ClientOrg.Y); 
    FBitmap.Canvas.Unlock; 

    // set alpha and have pre-multiplied color values 
    for Y := 0 to (FBitmap.Height - 1) do begin 
    Pixel := FBitmap.ScanLine[Y]; 
    for X := 0 to (FBitmap.Width - 1) do begin 
     Pixel.rgbRed := MulDiv($FF, Alpha, $FF); // red tint 
     Pixel.rgbGreen := MulDiv(Pixel.rgbGreen, Alpha, $FF); 
     Pixel.rgbBlue := MulDiv(Pixel.rgbBlue, Alpha, $FF); 
     Pixel.rgbReserved := Alpha; 
     Inc(Pixel); 
    end; 
    end; 

    BlendFunction.BlendOp := AC_SRC_OVER; 
    BlendFunction.BlendFlags := 0; 
    BlendFunction.SourceConstantAlpha := 255; 
    BlendFunction.AlphaFormat := AC_SRC_ALPHA; 

    BitmapPos := Point(0, 0); 
    BitmapSize.cx := Width; 
    BitmapSize.cy := Height; 
    UpdateLayeredWindow(Handle, 0, nil, @BitmapSize, FBitmap.Canvas.Handle, 
     @BitmapPos, 0, @BlendFunction, ULW_ALPHA); 
end; 

El formulario anterior se ve así:

Answer 2

Siempre se puede crear la forma en la forma. No es la solución más feliz, pero funciona.Que creo la mejor manera de resolver este problema sería mediante la utilización de GDI + o D2D, pero, por desgracia, no podía entenderlo, así que fui con el enfoque de "forma en forma":

forma en capas:

unit uLayeredForm; 

interface 

uses 
    Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes, System.Types, 
    Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Imaging.PngImage; 

type 
    TfrmLayered = class(TForm) 
    procedure FormActivate(Sender: TObject); 
    private 
    FParentForm: TForm; 
    procedure SetAlphaBackground(const AResourceName: String); 
    public 
    constructor Create(AOwner: TComponent; const ABitmapResourceName: String); reintroduce; 
    procedure UpdatePosition; 
    end; 

var 
    frmLayered: TfrmLayered; 

implementation 

{$R *.dfm} 


constructor TfrmLayered.Create(AOwner: TComponent; const ABitmapResourceName: String); 
begin 
    inherited Create(AOwner); 

    FParentForm := AOwner as TForm; 
    SetAlphaBackground(ABitmapResourceName); 
end; 

procedure TfrmLayered.FormActivate(Sender: TObject); 
begin 
    if (Active) and (FParentForm.Visible) and (Assigned(FParentForm)) then 
    FParentForm.SetFocus; 
end; 

procedure TfrmLayered.UpdatePosition; 
begin 
    if Assigned(FParentForm) then 
    begin 
    Left := FParentForm.Left - (ClientWidth - FParentForm.ClientWidth) div 2 - 1; 
    Top := FParentForm.Top - (ClientHeight - FParentForm.ClientHeight) div 2 - 1; 
    end; 
end; 

procedure TfrmLayered.SetAlphaBackground(const AResourceName: String); 
var 
    blend_func: TBlendFunction; 
    imgpos : TPoint; 
    imgsize : TSize; 
    exStyle : DWORD; 
    png  : TPngImage; 
    bmp  : TBitmap; 
begin 
    // enable window layering 
    exStyle := GetWindowLongA(Handle, GWL_EXSTYLE); 
    if ((exStyle and WS_EX_LAYERED) = 0) then 
    SetWindowLong(Handle, GWL_EXSTYLE, exStyle or WS_EX_LAYERED); 

    png := TPngImage.Create; 
    try 
    png.LoadFromResourceName(HInstance, AResourceName); 

    bmp := TBitmap.Create; 
    try 
     bmp.Assign(png); 

     // resize the form 
     ClientWidth := bmp.Width; 
     ClientHeight := bmp.Height; 

     // position image on form 
     imgpos := Point(0, 0); 
     imgsize.cx := bmp.Width; 
     imgsize.cy := bmp.Height; 

     // setup alpha blending parameters 
     blend_func.BlendOp := AC_SRC_OVER; 
     blend_func.BlendFlags := 0; 
     blend_func.SourceConstantAlpha := 255; 
     blend_func.AlphaFormat := AC_SRC_ALPHA; 

     UpdateLayeredWindow(Handle, 0, nil, @imgsize, bmp.Canvas.Handle, @imgpos, 0, @blend_func, ULW_ALPHA); 
    finally 
     bmp.Free; 
    end; 
    finally 
    png.Free; 
    end; 
end; 

end. 

forma principal:

unit uMainForm; 

interface 

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

type 
    TfrmMain = class(TForm) 
    imgClose: TImage; 
    procedure FormCreate(Sender: TObject); 
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 
    procedure FormShow(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure FormHide(Sender: TObject); 
    procedure imgCloseClick(Sender: TObject); 
    private 
    FLayeredForm: TfrmLayered; 
    protected 
    procedure WMMove(var AMessage: TMessage); message WM_MOVE; 
    public 
    end; 

var 
    frmMain: TfrmMain; 

implementation 

{$R *.dfm} 

uses 
    uCommon, Vcl.Themes, Vcl.Styles.FormStyleHooks; 



procedure TfrmMain.FormCreate(Sender: TObject); 
begin 
    {$IFDEF DEBUG} ReportMemoryLeaksOnShutdown := TRUE; {$ENDIF} 

    FLayeredForm := TfrmLayered.Create(self, 'MainBackground'); 
    FLayeredForm.Visible := TRUE; 
end; 

procedure TfrmMain.FormDestroy(Sender: TObject); 
begin 
    FLayeredForm.Free; 
end; 

procedure TfrmMain.FormHide(Sender: TObject); 
begin 
    FLayeredForm.Hide; 
end; 

procedure TfrmMain.WMMove(var AMessage: TMessage); 
begin 
    if Assigned(FLayeredForm) then 
    FLayeredForm.UpdatePosition; 

    inherited; 
end; 

procedure TfrmMain.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 
begin 
    FormMove(self, Button, Shift, X, Y); 
end; 

procedure TfrmMain.FormShow(Sender: TObject); 
begin 
    if Assigned(FLayeredForm) then 
    begin 
    FLayeredForm.Show; 
    FLayeredForm.UpdatePosition; 
    end; 
end; 

procedure TfrmMain.imgCloseClick(Sender: TObject); 
begin 
    Close; 
end; 

initialization 
    TStyleManager.Engine.RegisterStyleHook(TfrmMain, TFormStyleHookBackground); 
    TFormStyleHookBackground.BackGroundSettings.Color := clBlack; 
    TFormStyleHookBackground.BackGroundSettings.Enabled := TRUE; 

end. 

como se puede ver, se tendrá que hacer un poco de trabajo manual para hacer dos formas se comportan como una sola, pero este código debería empezar.

Como necesitaba formularios con bordes redondeados lisos, la siguiente captura de pantalla es lo que obtuve como resultado final. Coloreé plena forma en gris, específicamente para este post, para la distinción fácil entre ella y capas forma negro:

Se puede ver claramente la diferencia entre las fronteras de forma grises con alias (hecho por SetWindowRgn() y CreateRoundRectRgn() API) y bordes de forma negra antialiased.