如何创建 alpha 混合面板？

Question

我正在尝试在 Delphi XE2 中显示真正的 alpha 混合 TPanel。 我在网上找到了很多尝试，但没有一个能正常工作。

我想要实现的是“半模态”形式。 一种以与在 Web 浏览器中看到的方式类似的方式显示在其他具有褪色背景的控件顶部的表单。

我让它以基本形式工作，但它存在以下问题：

• 调整面板大小时出现大量闪烁。
• 如果将控件移到面板顶部，则会留下痕迹。

这是我迄今为止的努力（基于我在这里找到的一些代码）。

unit SemiModalFormU;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls;

type
  ISemiModalResultHandler = interface
    ['{0CC5A5D0-1545-4257-A936-AD777E0DAFCF}']
    procedure SemiModalFormClosed(Form: TForm);
  end;

  TTransparentPanel = class(TCustomPanel)
  private
    FBackground: TBitmap;
    FBlendColor: TColor;
    FBlendAlpha: Byte;

    procedure ColorBlend(const ACanvas: TCanvas; const ARect: TRect; const ABlendColor: TColor; const ABlendValue: Byte);
    procedure SetBlendAlpha(const Value: Byte);
    procedure SetBlendColor(const Value: TColor);
  protected
    procedure CaptureBackground;
    procedure Paint; override;

    procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;
    procedure WMMove(var Message: TMessage); message WM_MOVE;
    procedure WMParentNotify(var Message: TWMParentNotify); message WM_PARENTNOTIFY;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    procedure ClearBackground;

    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  published
    property BlendColor: TColor read FBlendColor write SetBlendColor;
    property BlendAlpha: Byte read FBlendAlpha write SetBlendAlpha;

    property Align;
    property Alignment;
    property Anchors;
  end;

  TSemiModalForm = class(TComponent)
  strict private
    FFormParent: TWinControl;
    FBlendColor: TColor;
    FBlendAlpha: Byte;
    FSemiModalResultHandler: ISemiModalResultHandler;
    FForm: TForm;
    FTransparentPanel: TTransparentPanel;
    FOldFormOnClose: TCloseEvent;
  private
    procedure OnTransparentPanelResize(Sender: TObject);
    procedure RepositionForm;
    procedure SetFormParent(const Value: TWinControl);
    procedure OnFormClose(Sender: TObject; var Action: TCloseAction);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    procedure ShowSemiModalForm(AForm: TForm; SemiModalResultHandler: ISemiModalResultHandler); virtual;

    property ModalPanel: TTransparentPanel read FTransparentPanel;
  published
    constructor Create(AOwner: TComponent); override;

    property BlendColor: TColor read FBlendColor write FBlendColor;
    property BlendAlpha: Byte read FBlendAlpha write FBlendAlpha;
    property FormParent: TWinControl read FFormParent write SetFormParent;
  end;

implementation

procedure TTransparentPanel.CaptureBackground;
var
  canvas: TCanvas;
  dc: HDC;
  sourcerect: TRect;
begin
  FBackground := TBitmap.Create;

  with Fbackground do
  begin
    width := clientwidth;
    height := clientheight;
  end;

  sourcerect.TopLeft := ClientToScreen(clientrect.TopLeft);
  sourcerect.BottomRight := ClientToScreen(clientrect.BottomRight);

  dc := CreateDC('DISPLAY', nil, nil, nil);
  try
    canvas := TCanvas.Create;
    try
      canvas.handle := dc;
      Fbackground.Canvas.CopyRect(clientrect, canvas, sourcerect);
    finally
      canvas.handle := 0;
      canvas.free;
    end;
  finally
    DeleteDC(dc);
  end;
end;

constructor TTransparentPanel.Create(aOwner: TComponent);
begin
  inherited;

  ControlStyle := controlStyle - [csSetCaption];

  FBlendColor := clWhite;
  FBlendAlpha := 200;
end;

destructor TTransparentPanel.Destroy;
begin
  FreeAndNil(FBackground);

  inherited;
end;

procedure TTransparentPanel.Paint;
begin
  if csDesigning in ComponentState then
    inherited
end;

procedure TTransparentPanel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if (Visible) and
     (HandleAllocated) and
     (not (csDesigning in ComponentState)) then
  begin
    FreeAndNil(Fbackground);

    Hide;

    inherited;

    Parent.Update;

    Show;
  end
  else
    inherited;
end;

procedure TTransparentPanel.WMEraseBkGnd(var msg: TWMEraseBkGnd);
var
  ACanvas: TCanvas;
begin
  if csDesigning in ComponentState then
    inherited
  else
  begin
    if not Assigned(FBackground) then
      Capturebackground;

    ACanvas := TCanvas.create;
    try
      ACanvas.handle := msg.DC;
      ACanvas.draw(0, 0, FBackground);
      ColorBlend(ACanvas, Rect(0, 0, Width, Height), FBlendColor, FBlendAlpha);
    finally
      FreeAndNil(ACanvas);
    end;

    msg.result := 1;
  end;
end;

procedure TTransparentPanel.WMMove(var Message: TMessage);
begin
 CaptureBackground;
end;

procedure TTransparentPanel.WMParentNotify(var Message: TWMParentNotify);
begin
  CaptureBackground;
end;

procedure TTransparentPanel.ClearBackground;
begin
  FreeAndNil(FBackground);
end;

procedure TTransparentPanel.ColorBlend(const ACanvas: TCanvas; const ARect: TRect;
  const ABlendColor: TColor; const ABlendValue: Byte);
var
  BMP: TBitmap;
begin
  BMP := TBitmap.Create;
  try
    BMP.Canvas.Brush.Color := ABlendColor;
    BMP.Width := ARect.Right - ARect.Left;
    BMP.Height := ARect.Bottom - ARect.Top;
    BMP.Canvas.FillRect(Rect(0,0,BMP.Width, BMP.Height));

    ACanvas.Draw(ARect.Left, ARect.Top, BMP, ABlendValue);
  finally
    FreeAndNil(BMP);
  end;
end;

procedure TTransparentPanel.SetBlendAlpha(const Value: Byte);
begin
  FBlendAlpha := Value;

  Paint;
end;

procedure TTransparentPanel.SetBlendColor(const Value: TColor);
begin
  FBlendColor := Value;

  Paint;
end;

{ TSemiModalForm }

constructor TSemiModalForm.Create(AOwner: TComponent);
begin
  inherited;

  FBlendColor := clWhite;
  FBlendAlpha := 150;

  FTransparentPanel := TTransparentPanel.Create(Self);
end;

procedure TSemiModalForm.SetFormParent(const Value: TWinControl);
begin
  FFormParent := Value;
end;

procedure TSemiModalForm.ShowSemiModalForm(AForm: TForm;
  SemiModalResultHandler: ISemiModalResultHandler);
begin
  if FForm = nil then
  begin
    FForm := AForm;
    FSemiModalResultHandler := SemiModalResultHandler;

    FTransparentPanel.Align := alClient;
    FTransparentPanel.BringToFront;
    FTransparentPanel.Parent := FFormParent;
    FTransparentPanel.BlendColor := FBlendColor;
    FTransparentPanel.BlendAlpha := FBlendAlpha;

    FTransparentPanel.OnResize := OnTransparentPanelResize;

    AForm.Parent := FTransparentPanel;
    FOldFormOnClose := AForm.OnClose;
    AForm.OnClose := OnFormClose;

    RepositionForm;

    AForm.Show;

    FTransparentPanel.ClearBackground;
    FTransparentPanel.Visible := TRUE;
  end;
end;

procedure TSemiModalForm.OnFormClose(Sender: TObject; var Action: TCloseAction);
begin
  FForm.OnClose := FOldFormOnClose;

  try
    FForm.Visible := FALSE;

    FSemiModalResultHandler.SemiModalFormClosed(FForm);
  finally
    FForm.Parent := nil;
    FForm := nil;

    FTransparentPanel.Visible := FALSE;
  end;
end;

procedure TSemiModalForm.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);

  if (Operation = opRemove) then
  begin
    if AComponent = FFormParent then
      SetFormParent(nil);
  end;
end;

procedure TSemiModalForm.OnTransparentPanelResize(Sender: TObject);
begin
  RepositionForm;
end;

procedure TSemiModalForm.RepositionForm;
begin
  FForm.Left := (FTransparentPanel.Width div 2) - (FForm.Width div 2);
  FForm.Top := (FTransparentPanel.Height div 2) - (FForm.Height div 2);
end;

end.

任何人都可以帮助我解决这些问题或将我指向一个已经存在的 alpha 混合面板吗？

Answer 1

感谢您的所有建议。 我已经接受了输入并创建了一个完全满足我需要的新组件。 这是它的样子：

将我指向正确方向的评论是我赞成的 NGLN 评论。 如果您将其发布为答案，我会接受。

我尝试将组件代码添加到此答案中，但 StackOverflow 无法正确格式化。 但是，您可以在此处下载源代码和完整的演示应用程序。

该组件提供以下功能：

• 半模态窗体是主窗体的子级。 这意味着它可以像其他控件一样被标签化。
• 覆盖区域绘制正确，没有人工制品。
• 覆盖区域下的控件将自动禁用。
• 如果需要，可以显示/隐藏半模态形式/覆盖，例如切换选项卡。
• SemiModalResult 在事件中被传回。

还有一些我想解决的小问题。 如果有人知道如何修复它们，请告诉我。

• 当父窗体被移动或调整大小时，它需要调用 ParentFormMoved 过程。 这允许组件调整覆盖表单的大小/重新定位。 有没有办法挂钩到父窗体并检测它何时被移动？
• 如果你模仿主窗体，然后恢复它，覆盖窗体立即出现，然后主窗体动画回到它以前的位置。 有没有办法检测主窗体何时完成动画？
• 半模态窗口的圆角不太漂亮。 我不确定可以做很多事情，因为它涉及到矩形区域。

Answer 2

您的代码没有以模态方式显示表单，我想知道您为什么不显示。 但是，也许我不理解semi modal一词。

无论如何，我认为创建一个半透明表单来显示实际对话框的想法会很好：

function ShowObviousModal(AForm: TForm; AParent: TWinControl = nil): Integer;
var
  Layer: TForm;
begin
  if AParent = nil then
    AParent := Application.MainForm;
  Layer := TForm.Create(nil);
  try
    Layer.AlphaBlend := True;
    Layer.AlphaBlendValue := 128;
    Layer.BorderStyle := bsNone;
    Layer.Color := clWhite;
    with AParent, ClientOrigin do
      SetWindowPos(Layer.Handle, HWND_TOP, X, Y, ClientWidth, ClientHeight,
        SWP_SHOWWINDOW);
    Result := AForm.ShowModal;
  finally
    Layer.Free;
  end;
end;

用法：

procedure TForm1.Button1Click(Sender: TObject);
begin
  FDialog := TForm2.Create(Self);
  try
    if ShowObviousModal(FDialog) = mrOk then
      Caption := 'OK';
  finally
    FDialog.Free;
  end;
end;