windowstransparencyvclrad-studio

RAD Studio XE7 - VCL - TSpeedButton lost its background transparency when hovered on Windows 11

In one of my VCL applications I'm using TSpeedButton components as an highlight effect visible when the component is hovered. I reproduced below a minimal example showing how I use a such component.

Main.h file:

#ifndef MainH
#define MainH

#include <System.Classes.hpp>
#include <Vcl.Controls.hpp>
#include <Vcl.StdCtrls.hpp>
#include <Vcl.Forms.hpp>
#include <Vcl.Buttons.hpp>
#include <Vcl.ExtCtrls.hpp>

class TMainForm : public TForm
{
    __published:
        TPanel *paBackground;
        TLabel *laCaption;
        TSpeedButton *btGlowEffect;

    public:
        __fastcall TMainForm(TComponent* pOwner);
};

extern PACKAGE TMainForm *MainForm;
#endif

Main.cpp file:

#include <vcl.h>
#pragma hdrstop

#include "Main.h"

#pragma package(smart_init)
#pragma resource "*.dfm"

//---------------------------------------------------------------------------
TMainForm *MainForm;
//---------------------------------------------------------------------------
__fastcall TMainForm::TMainForm(TComponent* pOwner)
    : TForm(pOwner)
{}
//---------------------------------------------------------------------------

Main.dfm file:

object MainForm: TMainForm
  Left = 0
  Top = 0
  Caption = 'MainForm'
  ClientHeight = 321
  ClientWidth = 678
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object paBackground: TPanel
    Left = 64
    Top = 16
    Width = 545
    Height = 49
    BevelOuter = bvNone
    TabOrder = 0
    object laCaption: TLabel
      Left = 0
      Top = 0
      Width = 545
      Height = 49
      Align = alClient
      Alignment = taCenter
      Caption = 'This is a demo text'
      Layout = tlCenter
      ExplicitWidth = 90
      ExplicitHeight = 13
    end
    object btGlowEffect: TSpeedButton
      Left = 0
      Top = 0
      Width = 545
      Height = 49
      Align = alClient
      Flat = True
      ExplicitLeft = 104
      ExplicitTop = 8
      ExplicitWidth = 23
      ExplicitHeight = 22
    end
  end
end

Here are the result I got on Windows 7 and Windows 10, when the component was hovered: enter image description here enter image description here

But on Windows 11, the result is the following: enter image description here

Apparently the TSpeedButton background on hover became opaque on Windows 11. This is not acceptable for me, and I need a quick solution. How can I restore the component transparency, without if possible having to change the component, or to overload it?

Solution

  • In fact this is a RAD Studio XE7 bug in Windows 11, which was fixed in newer RAD Studio versions (I tested Alexandria). However I don't like the new visual, which is just a bevel frame around the button, so I publish below my own modification:

    procedure TSpeedButton.Paint;

  function DoGlassPaint: Boolean;
  var
    LParent: TWinControl;
  begin
    Result := csGlassPaint in ControlState;
    if Result then
    begin
      LParent := Parent;
      while (LParent <> nil) and not LParent.DoubleBuffered do
        LParent := LParent.Parent;
      Result := (LParent = nil) or not LParent.DoubleBuffered or (LParent is TCustomForm);
    end;
  end;

var
  PaintRect: TRect;
  DrawFlags: Integer;
  Offset: TPoint;
  LGlassPaint: Boolean;
  Button: TThemedButton;
  ToolButton: TThemedToolBar;
  Details: TThemedElementDetails;
  LStyle: TCustomStyleServices;
  MemDC: HDC;
  PaintBuffer: HPAINTBUFFER;
  LCanvas: TCanvas;
  overlay: TBitmap;
  blendFunction: TBlendFunction;
begin
  if not Enabled then
  begin
    FState := bsDisabled;
    FDragging := False;
  end
  else if FState = bsDisabled then
    if FDown and (GroupIndex <> 0) then
      FState := bsExclusive
    else
      FState := bsUp;
  Canvas.Font := Self.Font;

  if ThemeControl(Self) then
  begin
    LGlassPaint := DoGlassPaint;
    if LGlassPaint then
      PaintBuffer := BeginBufferedPaint(Canvas.Handle, ClientRect, BPBF_TOPDOWNDIB, nil, MemDC)
    else PaintBuffer := 0;
    LCanvas := TCanvas.Create;
    try
      if LGlassPaint then
        LCanvas.Handle := MemDC
      else LCanvas.Handle := Canvas.Handle;

      LCanvas.Font := Self.Font;

      if not LGlassPaint then
        if Transparent then
          StyleServices.DrawParentBackground(0, LCanvas.Handle, nil, True)
        else
          PerformEraseBackground(Self, LCanvas.Handle)
      else
        FillRect(LCanvas.Handle, ClientRect, GetStockObject(BLACK_BRUSH));

      if not Enabled then
        Button := tbPushButtonDisabled
      else
        if FState in [bsDown, bsExclusive] then
          Button := tbPushButtonPressed
        else
          if MouseInControl then
            Button := tbPushButtonHot
          else
            Button := tbPushButtonNormal;

      ToolButton := ttbToolbarDontCare;
      if FFlat or TStyleManager.IsCustomStyleActive then
      begin
        case Button of
          tbPushButtonDisabled:
            Toolbutton := ttbButtonDisabled;
          tbPushButtonPressed:
            Toolbutton := ttbButtonPressed;
          tbPushButtonHot:
            Toolbutton := ttbButtonHot;
          tbPushButtonNormal:
            Toolbutton := ttbButtonNormal;
        end;
      end;

      PaintRect := ClientRect;
      if ToolButton = ttbToolbarDontCare then
      begin
        Details := StyleServices.GetElementDetails(Button);
        StyleServices.DrawElement(LCanvas.Handle, Details, PaintRect);
        StyleServices.GetElementContentRect(LCanvas.Handle, Details, PaintRect, PaintRect);
      end
      else
      begin
        Details := StyleServices.GetElementDetails(ToolButton);
        if not TStyleManager.IsCustomStyleActive then
        begin
          if FFlat {and (Tag = 999)} and MouseInControl then
          begin
            // create an overlay bitmap
            overlay             := TBitmap.Create();
            overlay.PixelFormat := pf32bit;
            overlay.AlphaFormat := afDefined;
            overlay.Transparent := True;
            overlay.SetSize(PaintRect.Width, PaintRect.Height);

            // fill it with blue color
            overlay.Canvas.Brush.Color := clHighlight;
            overlay.Canvas.Brush.Style := bsSolid;
            overlay.Canvas.FillRect(PaintRect);

            // initialize blend operation
            blendFunction.BlendOp             := AC_SRC_OVER;
            blendFunction.BlendFlags          := 0;
            blendFunction.SourceConstantAlpha := 32;
            blendFunction.AlphaFormat         := 0;

            // draw the hover state
            AlphaBlend(LCanvas.Handle, 0, 0, PaintRect.Width, PaintRect.Height,
              overlay.Canvas.Handle, 0, 0, PaintRect.Width, PaintRect.Height, blendFunction);

            overlay.Free;

            // enable this code to draw a rect around the selection
            {
            LCanvas.Pen.Color := clGradientActiveCaption;
            LCanvas.MoveTo(0, PaintRect.Height - 1);
            LCanvas.LineTo(0, 0);
            LCanvas.LineTo(PaintRect.Width - 1, 0);
            LCanvas.Pen.Color := clHighlight;
            LCanvas.LineTo(PaintRect.Width - 1, PaintRect.Height - 1);
            LCanvas.LineTo(0, PaintRect.Height - 1);
            }
          end
          else
            StyleServices.DrawElement(LCanvas.Handle, Details, PaintRect);

          // Windows theme services doesn't paint disabled toolbuttons
          // with grayed text (as it appears in an actual toolbar). To workaround,
          // retrieve Details for a disabled button for drawing the caption.
          if (ToolButton = ttbButtonDisabled) then
            Details := StyleServices.GetElementDetails(Button);
        end
        else
        begin
          // Special case for flat speedbuttons with custom styles. The assumptions
          // made about the look of ToolBar buttons may not apply, so only paint
          // the hot and pressed states , leaving normal/disabled to appear flat.
          if not FFlat or ((Button = tbPushButtonPressed) or (Button = tbPushButtonHot)) then
            StyleServices.DrawElement(LCanvas.Handle, Details, PaintRect);
        end;
        StyleServices.GetElementContentRect(LCanvas.Handle, Details, PaintRect, PaintRect);
      end;

      Offset := Point(0, 0);
      if Button = tbPushButtonPressed then
      begin
        // A pressed "flat" speed button has white text in XP, but the Themes
        // API won't render it as such, so we need to hack it.
        if (ToolButton <> ttbToolbarDontCare) and not CheckWin32Version(6) then
          LCanvas.Font.Color := clHighlightText
        else
          if FFlat then
            Offset := Point(1, 0);
      end;
      TButtonGlyph(FGlyph).FPaintOnGlass := LGlassPaint;
      TButtonGlyph(FGlyph).FThemeDetails := Details;
      TButtonGlyph(FGlyph).FThemesEnabled := True;
      TButtonGlyph(FGlyph).FThemeTextColor := seFont in StyleElements;
      TButtonGlyph(FGlyph).Draw(LCanvas, PaintRect, Offset, Caption, FLayout,
        FMargin, FSpacing, FState, Transparent, DrawTextBiDiModeFlags(0));

      if LGlassPaint then
        BufferedPaintMakeOpaque(PaintBuffer, ClientRect);
    finally
      LCanvas.Handle := 0;
      LCanvas.Free;
      if LGlassPaint then
        EndBufferedPaint(PaintBuffer, True);
    end
  end
  else
  begin
    PaintRect := Rect(0, 0, Width, Height);
    if not FFlat then
    begin
      DrawFlags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
      if FState in [bsDown, bsExclusive] then
        DrawFlags := DrawFlags or DFCS_PUSHED;
      DrawFrameControl(Canvas.Handle, PaintRect, DFC_BUTTON, DrawFlags);
    end
    else
    begin
      if (FState in [bsDown, bsExclusive]) or
        (FMouseInControl and (FState <> bsDisabled)) or
        (csDesigning in ComponentState) then
        DrawEdge(Canvas.Handle, PaintRect, DownStyles[FState in [bsDown, bsExclusive]],
          FillStyles[Transparent] or BF_RECT)
      else if not Transparent then
      begin
        Canvas.Brush.Color := Color;
        Canvas.FillRect(PaintRect);
      end;
      InflateRect(PaintRect, -1, -1);
    end;
    if FState in [bsDown, bsExclusive] then
    begin
      if (FState = bsExclusive) and (not FFlat or not FMouseInControl) then
      begin
        Canvas.Brush.Bitmap := AllocPatternBitmap(clBtnFace, clBtnHighlight);
        Canvas.FillRect(PaintRect);
      end;
      Offset.X := 1;
      Offset.Y := 1;
    end
    else
    begin
      Offset.X := 0;
      Offset.Y := 0;
    end;

    LStyle := StyleServices;
    TButtonGlyph(FGlyph).FThemesEnabled := LStyle.Enabled;
    TButtonGlyph(FGlyph).Draw(Canvas, PaintRect, Offset, Caption, FLayout, FMargin,
      FSpacing, FState, Transparent, DrawTextBiDiModeFlags(0));
  end;
end;

    NOTE I modified directly the Vcl.Buttons.pas file in my case, although I had good reasons to do that I know that this isn't a good solution, I don't recommend it. If you want to fix it once for all, either upgrade to a newer RAD Studio version which fix the bug, or if you don't like the new visual, as it's the case for me, implement the above solution in your own custom component inherited from TSpeedButton.