RAD Studio XE7 - VCL - TSpeedButton 在 Windows 11 上悬停时失去背景透明度

Question

在我的一个 VCL 应用程序中，我使用 TSpeedButton 组件作为悬停组件时可见的突出显示效果。我在下面复制了一个最小的示例，展示了我如何使用此类组件。

Main.h 文件：

#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

主.cpp文件：

#include <vcl.h>
#pragma hdrstop

#include "Main.h"

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

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

主.dfm文件：

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

以下是我在 Windows 7 和 Windows 10 上悬停组件时得到的结果：

但是在Windows 11上，结果如下：

显然，悬停时的 TSpeedButton 背景在 Windows 11 上变得不透明。这对我来说是不可接受的，我需要一个快速的解决方案。如何恢复组件透明度，而无需更改组件或使其过载？

Answer 1

事实上，这是 Windows 11 中的 RAD Studio XE7 错误，已在较新版本中修复（我测试了 Alexandria）。但是我不喜欢这个错误的修复方式，所以我在下面发布了我自己的修改：

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;

注意在我的案例中，我直接修改了

Vcl.Buttons.pas

文件，尽管我有充分的理由，我知道这不是一个好的解决方案，但我不推荐它。如果您想一次性修复它，请升级到修复该错误的更新的 RAD Studio 版本，或者如果您不喜欢新的视觉效果（就像我的情况一样），请在您自己的自定义组件中实现上述解决方案继承自

TSpeedButton

。