如何创建alpha混合面板？

时间：2012-10-11 14:41:35

标签： delphi delphi-xe2

我正在尝试在Delphi XE2中显示真正的alpha混合TPanel。我在网上发现了不少尝试，但都没有正常工作。

我想要实现的是“半模式”形式。显示在其他控件顶部的窗体，其背景类似于Web浏览器中显示的褪色背景。

enter image description here

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

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

到目前为止，这是我的努力（基于我找到的一些代码here）。

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混合面板？

2 个答案:

答案 0 :(得分：9)

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

enter image description here

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

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

该组件提供以下功能：

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

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

  • 当父表单被移动或调整大小时，它需要调用 ParentFormMoved过程。这允许组件 调整叠加形式的大小/重新定位。有没有办法搞定 父表单并检测它何时被移动？
  • 如果您最小化主窗体，然后恢复它，立即显示叠加窗体，然后将主窗体动画回到它之前的位置。有没有办法检测主窗体何时完成动画？
  • 半模态窗口的圆角不太漂亮。我＆＃39;米 不确定那可以做些什么，因为它可以做到这一点 矩形区域。

答案 1 :(得分：2)

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

无论如何，我认为the idea创建一个半透明的表单来显示实际的对话框就可以了：

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;
相关问题
最新问题