Я пытаюсь отобразить по-настоящему альфа-смешанную 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.
Может ли кто-нибудь помочь мне с проблемами или указать мне на панель альфа-смеси, которая уже существует?