Как создать альфа-смешанную панель?

Я пытаюсь отобразить по-настоящему альфа-смешанную TPanel в Delphi XE2. Я нашел несколько попыток в Интернете, но никто из них не работает правильно.

То, что я пытаюсь достичь, - это "полумодальная" форма. Форма, отображаемая поверх других элементов управления с выцветшим фоном, аналогично тому, как это видно в веб-браузерах.

У меня он работает в базовой форме, но он страдает следующими проблемами:

Большое количество мерцания при изменении размера панели.
Если элемент управления перемещается поверх панели, он оставляет след.

Здесь мои усилия до сих пор (на основе некоторого кода я нашел здесь).

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.

Может ли кто-нибудь помочь мне с проблемами или указать мне на панель альфа-смеси, которая уже существует?

Ответ 1

Спасибо за все ваши предложения. Я взял данные и создал новый компонент, который делает именно то, что мне нужно. Вот как это выглядит:

Комментарий, который указал мне в правильном направлении, был следующим: NGLN, который я поддерживал. Если вы опубликуете его в качестве ответа, я его приму.

Я попытался добавить код компонента к этому ответу, но StackOverflow не форматировал его правильно. Однако вы можете скачать источник и полное демо-приложение здесь.

Компонент предоставляет следующие функции:

Полумодальная форма - это ребенок основной формы. Это означает, что это могут быть внесены в закладки так же, как и другие элементы управления.
Область перекрытия рисуется правильно без артефактов.
Элементы управления в области перекрытия автоматически отключены.
Полумодальная форма/наложение может быть отображено/скрыто, если требуется, например. переключение вкладок.
SemiModalResult возвращается в событие.

Есть еще ряд мелких проблем, которые я хотел бы сгладить. Если кто-нибудь знает, как их исправить, сообщите мне.

При перемещении или изменении родительской формы необходимо вызвать Процедура ParentFormMoved. Это позволяет компоненту изменить размер/изменить форму оверлея. Есть ли способ зацепить родительскую форму и определить, когда она перемещена?
Если вы имитируете основную форму, затем восстановите ее, форма наложения появится сразу, затем основная форма будет анимирована назад к предыдущей позиции. Есть ли способ обнаружить, когда основная форма закончила анимацию?
Округлые углы полумодного окна не слишком хороши. я не уверен, что многое можно сделать по этому поводу, так как оно прямоугольная область.

Ответ 2

В вашем коде не отображается формально, и мне интересно, почему вы этого не сделали. Но тогда, может быть, я не понимаю термин полумодальный.

В любом случае, я думаю, идея создать полупрозрачную форму, на которой показать фактический диалог будет очень хорошо:

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;