Quick question in regard to Delphi XE.
I'm trying to make a customized circle-shape component that has transparent background, so that when added on a form, the component can overlap other components. I've tried Brush.Style:=bsTransparent; or ellipse() and more on... but still couldn't find a way to make the edge area transparent.
Is there anyway I can make the edge area of the component transparent without using other lib or api?
Well here's a quick answer, that should get you going.
type
TEllipticPanel = class(Vcl.ExtCtrls.TPanel)
procedure CreateWnd; override;
procedure Paint; override;
procedure Resize; override;
procedure RecreateHRGN;
end;
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
panl: TEllipticPanel;
public
{ Public declarations }
end;
implementation
procedure TForm1.FormCreate(Sender: TObject);
begin
panl := TEllipticPanel.Create(self);
panl.Left := 10;
panl.Top := 10;
panl.Width := 100;
panl.Height := 50;
panl.ParentBackground := False;
panl.ParentColor := False;
panl.Color := clYellow;
panl.Parent := self;
end;
{ TEllipticPanel }
procedure TEllipticPanel.RecreateHRGN;
var
hr: hRgn;
begin
inherited;
hr := CreateEllipticRgn(0,0,Width,Height);
SetWindowRgn(Handle, hr, True);
end;
procedure TEllipticPanel.CreateWnd;
begin
inherited;
RecreateHRGN;
end;
procedure TEllipticPanel.Paint;
begin
inherited;
Canvas.Brush.Style := bsClear;
Canvas.Pen.Style := TPenStyle(psSolid);
Canvas.Pen.Width := 1;
Canvas.Pen.Color := clGray;
Canvas.Ellipse(1,1,Width-2,Height-2);
end;
procedure TEllipticPanel.Resize;
begin
inherited;
RecreateHRGN;
end;
The key is the Windows CreateEllipticRgn and the GDI SetWindowRgn functions.
For more information about windows regions see Regions.
Related
I simply can't figure out what I'm doing wrong when trying to paint a control.
I've tried using TCanvas.BeginScene()/TCanvas.EndScene(), tried painting in other methods (for example main form OnPaint()).
I've tried TControl.InvalidateRect().
I get nothing.
Here's what I have in my test app:
type
TTestControl = class(TControl)
protected
procedure Paint; override;
end;
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
fTestControl: TTestControl;
end;
procedure TTestControl.Paint;
begin
Canvas.Fill.Color := TColorRec.Blueviolet;
Canvas.FillEllipse(ClipRect, AbsoluteOpacity);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
fTestControl := TTestControl.Create(Self);
fTestControl.Parent := Self;
fTestControl.Align := TAlignLayout.Client;
end;
It ought to be enough, according to what's online.
Any suggestions?
The Canvas.Fill.Color is a TAlphaColor.
Change the line
Canvas.Fill.Color := TColorRec.Blueviolet;
to
Canvas.Fill.Color := TAlphaColors.Blueviolet;
Your Paint methods should be like this:
procedure TTestControl.Paint;
begin
inherited;
Canvas.BeginScene;
Canvas.Fill.Color := claBlueviolet;
Canvas.FillEllipse(ClipRect, AbsoluteOpacity);
Canvas.EndScene;
end;
I, also, think you should override the DoPaint method of TControl and not the Paint.
I feel my failure so far lies in search terms as information on this has to be pretty common. Basically I am looking for common solutions and best practices when performing resizes on several components while a form is resized.
I have a form with a component that is based upon TScrollBox. The ScrollBox contains rows which are added dynamically at run time. They are basically a subcomponent. Each one has an image on the left and a memo on the right. The height is set based upon the width and aspect ratio of the image. Upon the resize of the scroll box a loop sets the width of the rows triggering the rows own internal resize. The loop also sets the relative top position if the heights have changed.
Screen shot:
Around 16 rows performs fine. My goal is closer to 32 rows which is very choppy and can peg a core at 100% usage.
I have tried:
Added a check to prevent a new resize starting while the previous has yet to complete. It answered if it occured and it does sometimes.
I tried preventing it resizing more often than every 30 ms which would allow for 30 frame per second drawing. Mixed results.
Changed the rows base component from TPanel to TWinControl. Not sure if there is a performance penalty using the Panel but its an old habit.
With and without double buffering.
I would like to allow row resizing to occur during a resize as a preview to how large the image will be in the row. That eliminates one obvious solution that in some applications is an acceptable loss.
Right now the resize code internally for the row is completely dynamic and based upon the dimensions of each image. Next thing I plan to try is to basically specify the Aspect Ratio, Max Width/Height based on the largest image in the collection. This should reduce the amount of math per row. But it seems like the issues are more the resize event and the loop itself?
Full unit code for the components:
unit rPBSSVIEW;
interface
uses
Classes, Controls, Forms, ExtCtrls, StdCtrls, Graphics, SysUtils, rPBSSROW, Windows, Messages;
type
TPBSSView = class(TScrollBox)
private
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure ResizeRows(Sender: TObject);
procedure AddRow(FileName: String);
procedure FillRow(Row: Integer; ImageStream: TMemoryStream);
end;
var
PBSSrow: Array of TPBSSRow;
Resizingn: Boolean;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TScrollBox]);
end;
procedure TPBSSView.AddRow(FileName: String);
begin
SetLength(PBSSrow,(Length(PBSSrow) + 1));
PBSSrow[Length(PBSSrow)-1] := TPBSSRow.create(self);
With PBSSrow[Length(PBSSrow)-1] do
begin
Left := 2;
if (Length(PBSSrow)-1) = 0 then Top := 2 else Top := ((PBSSRow[Length(PBSSRow) - 2].Top + PBSSRow[Length(PBSSRow) - 2].Height) + 2);
Width := (inherited ClientWidth - 4);
Visible := True;
Parent := Self;
PanelLeft.Caption := FileName;
end;
end;
procedure TPBSSView.FillRow(Row: Integer; ImageStream: TMemoryStream);
begin
PBSSRow[Row].LoadImageFromStream(ImageStream);
end;
procedure TPBSSView.ResizeRows(Sender: TObject);
var
I, X: Integer;
begin
if Resizingn then exit
else
begin
Resizingn := True;
HorzScrollBar.Visible := False;
X := (inherited ClientWidth - 4);
if Length(PBSSrow) > 0 then
for I := 0 to Length(PBSSrow) - 1 do
Begin
PBSSRow[I].Width := X; //Set Width
if not (I = 0) then //Move all next ones down.
begin
PBSSRow[I].Top := (PBSSRow[(I - 1)].Top + PBSSRow[(I - 1)].Height) + 2;
end;
Application.ProcessMessages;
End;
HorzScrollBar.Visible := True;
Resizingn := False;
end;
end;
constructor TPBSSView.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
OnResize := ResizeRows;
DoubleBuffered := True;
VertScrollBar.Tracking := True;
Resizingn := False;
end;
destructor TPBSSView.Destroy;
begin
inherited;
end;
end.
Row Code:
unit rPBSSROW;
interface
uses
Classes, Controls, Forms, ExtCtrls, StdCtrls, Graphics, pngimage, SysUtils;
type
TPBSSRow = class(TWinControl)
private
FImage: TImage;
FPanel: TPanel;
FMemo: TMemo;
FPanelLeft: TPanel;
FPanelRight: TPanel;
FImageWidth: Integer;
FImageHeight: Integer;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure MyPanelResize(Sender: TObject);
procedure LeftPanelResize(Sender: TObject);
published
procedure LoadImageFromStream(ImageStream: TMemoryStream);
property Image: TImage read FImage;
property Panel: TPanel read FPanel;
property PanelLeft: TPanel read FPanelLeft;
property PanelRight: TPanel read FPanelRight;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Standard', [TWinControl]);
end;
procedure TPBSSRow.MyPanelResize(Sender: TObject);
begin
if (Width - 466) <= FImageWidth then FPanelLeft.Width := (Width - 466)
else FPanelLeft.Width := FImageWidth;
FPanelRight.Width := (Width - FPanelLeft.Width);
end;
procedure TPBSSRow.LeftPanelResize(Sender: TObject);
var
AspectRatio: Extended;
begin
FPanelRight.Left := (FPanelLeft.Width);
//Enforce Info Minimum Height or set Height
if FImageHeight > 0 then AspectRatio := (FImageHeight/FImageWidth) else
AspectRatio := 0.4;
if (Round(AspectRatio * FPanelLeft.Width)) >= 212 then
begin
Height := (Round(AspectRatio * FPanelLeft.Width));
FPanelLeft.Height := Height;
FPanelRight.Height := Height;
end
else
begin
Height :=212;
FPanelLeft.Height := Height;
FPanelRight.Height := Height;
end;
if Fimage.Height >= FImageHeight then FImage.Stretch := False else Fimage.Stretch := True;
if Fimage.Width >= FImageWidth then FImage.Stretch := False else Fimage.Stretch := True;
end;
procedure TPBSSRow.LoadImageFromStream(ImageStream: TMemoryStream);
var
P: TPNGImage;
n: Integer;
begin
P := TPNGImage.Create;
ImageStream.Position := 0;
P.LoadFromStream(ImageStream);
FImage.Picture.Assign(P);
FImageWidth := P.Width;
FImageHeight := P.Height;
end;
constructor TPBSSRow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
BevelInner := bvNone;
BevelOuter := bvNone;
BevelKind := bkNone;
Color := clWhite;
OnResize := MyPanelResize;
DoubleBuffered := True;
//Left Panel for Image
FPanelLeft := TPanel.Create(Self);
with FPanelLeft do
begin
SetSubComponent(true);
Align := alLeft;
Parent := Self;
//SetBounds(0,0,100,100);
ParentBackground := False;
Color := clBlack;
Font.Color := clLtGray;
Constraints.MinWidth := 300;
BevelInner := bvNone;
BevelOuter := bvNone;
BevelKind := bkNone;
BorderStyle := bsNone;
OnResize := LeftPanelResize;
end;
//Image for left panel
FImage := TImage.Create(Self);
FImage.SetSubComponent(true);
FImage.Align := alClient;
FImage.Parent := FPanelLeft;
FImage.Center := True;
FImage.Stretch := True;
FImage.Proportional := True;
//Right Panel for Info
FPanelRight := TPanel.Create(Self);
with FPanelRight do
begin
SetSubComponent(true);
Parent := Self;
Padding.SetBounds(2,5,5,2);
BevelInner := bvNone;
BevelOuter := bvNone;
BevelKind := bkNone;
BorderStyle := bsNone;
Color := clLtGray;
end;
//Create Memo in Right Panels
FMemo := TMemo.create(self);
with FMemo do
begin
SetSubComponent(true);
Parent := FPanelRight;
Align := alClient;
BevelOuter := bvNone;
BevelInner := bvNone;
BorderStyle := bsNone;
Color := clLtGray;
end;
end;
destructor TPBSSRow.Destroy;
begin
inherited;
end;
end.
A few tips:
TWinControl already ís a container, you do not need another panel inside it to add controls
You do not need an TImage component to view a graphic, that can also with TPaintBox, or as in my example control below, a TCustomControl,
Since all of your other panels are not recognizable (borders and bevels are disabled), loose them altogether and place the TMemo directly on your row control,
SetSubComponent is only for design time usage. You do not need it. Nor the Register procedures for that matter.
Put the global rows array inside your class definition, otherwise multiple TPBSSView controls will use the same array!
TWinControl already tracks all its child controls, so you won't need the array anyway, see my example below,
Make use of the Align property to save you from realigning manually,
If the memo control is just for showing text, then remove it and paint the text yourself.
Try this one for starters:
unit PBSSView;
interface
uses
Windows, Messages, Classes, Controls, SysUtils, Graphics, ExtCtrls, StdCtrls,
Forms, PngImage;
type
TPBSSRow = class(TCustomControl)
private
FGraphic: TPngImage;
FStrings: TStringList;
function ImageHeight: Integer; overload;
function ImageHeight(ControlWidth: Integer): Integer; overload;
function ImageWidth: Integer; overload;
function ImageWidth(ControlWidth: Integer): Integer; overload;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
procedure WMWindowPosChanging(var Message: TWMWindowPosChanging);
message WM_WINDOWPOSCHANGING;
protected
procedure Paint; override;
procedure RequestAlign; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure LoadImageFromStream(Stream: TMemoryStream);
property Strings: TStringList read FStrings;
end;
TPBSSView = class(TScrollBox)
private
function GetRow(Index: Integer): TPBSSRow;
procedure WMEnterSizeMove(var Message: TMessage); message WM_ENTERSIZEMOVE;
procedure WMEraseBkgnd(var Message: TWmEraseBkgnd); message WM_ERASEBKGND;
procedure WMExitSizeMove(var Message: TMessage); message WM_EXITSIZEMOVE;
protected
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
procedure AddRow(const FileName: TFileName);
procedure FillRow(Index: Integer; ImageStream: TMemoryStream);
property Rows[Index: Integer]: TPBSSRow read GetRow;
end;
implementation
{ TPBSSRow }
constructor TPBSSRow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 300;
Height := 50;
FStrings := TStringList.Create;
end;
destructor TPBSSRow.Destroy;
begin
FStrings.Free;
FGraphic.Free;
inherited Destroy;
end;
function TPBSSRow.ImageHeight: Integer;
begin
Result := ImageHeight(Width);
end;
function TPBSSRow.ImageHeight(ControlWidth: Integer): Integer;
begin
if (FGraphic <> nil) and not FGraphic.Empty then
Result := Round(ImageWidth(ControlWidth) * FGraphic.Height / FGraphic.Width)
else
Result := Height;
end;
function TPBSSRow.ImageWidth: Integer;
begin
Result := ImageWidth(Width);
end;
function TPBSSRow.ImageWidth(ControlWidth: Integer): Integer;
begin
Result := ControlWidth div 2;
end;
procedure TPBSSRow.LoadImageFromStream(Stream: TMemoryStream);
begin
FGraphic.Free;
FGraphic := TPngImage.Create;
Stream.Position := 0;
FGraphic.LoadFromStream(Stream);
Height := ImageHeight + Padding.Bottom;
end;
procedure TPBSSRow.Paint;
var
R: TRect;
begin
Canvas.StretchDraw(Rect(0, 0, ImageWidth, ImageHeight), FGraphic);
SetRect(R, ImageWidth, 0, Width, ImageHeight);
Canvas.FillRect(R);
Inc(R.Left, 10);
DrawText(Canvas.Handle, FStrings.Text, -1, R, DT_EDITCONTROL or
DT_END_ELLIPSIS or DT_NOFULLWIDTHCHARBREAK or DT_NOPREFIX or DT_WORDBREAK);
Canvas.FillRect(Rect(0, ImageHeight, Width, Height));
end;
procedure TPBSSRow.RequestAlign;
begin
{eat inherited}
end;
procedure TPBSSRow.WMEraseBkgnd(var Message: TWmEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TPBSSRow.WMWindowPosChanging(var Message: TWMWindowPosChanging);
begin
inherited;
if (FGraphic <> nil) and not FGraphic.Empty then
Message.WindowPos.cy := ImageHeight(Message.WindowPos.cx) + Padding.Bottom;
end;
{ TPBSSView }
procedure TPBSSView.AddRow(const FileName: TFileName);
var
Row: TPBSSRow;
begin
Row := TPBSSRow.Create(Self);
Row.Align := alTop;
Row.Padding.Bottom := 2;
Row.Parent := Self;
end;
constructor TPBSSView.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
VertScrollBar.Tracking := True;
end;
procedure TPBSSView.FillRow(Index: Integer; ImageStream: TMemoryStream);
begin
Rows[Index].LoadImageFromStream(ImageStream);
end;
function TPBSSView.GetRow(Index: Integer): TPBSSRow;
begin
Result := TPBSSRow(Controls[Index]);
end;
procedure TPBSSView.PaintWindow(DC: HDC);
begin
{eat inherited}
end;
procedure TPBSSView.WMEnterSizeMove(var Message: TMessage);
begin
if not AlignDisabled then
DisableAlign;
inherited;
end;
procedure TPBSSView.WMEraseBkgnd(var Message: TWmEraseBkgnd);
var
DC: HDC;
begin
DC := GetDC(Handle);
try
FillRect(DC, Rect(0, VertScrollBar.Range, Width, Height), Brush.Handle);
finally
ReleaseDC(Handle, DC);
end;
Message.Result := 1;
end;
procedure TPBSSView.WMExitSizeMove(var Message: TMessage);
begin
inherited;
if AlignDisabled then
EnableAlign;
end;
end.
If this still performs badly, then there are multiple other enhancements possible.
Update:
Flickering eliminated by overriding/intercepting WM_ERASEBKGND (and intercepting PaintWindow for versions < XE2),
Better performance by making use of DisableAlign and EnableAlign.
I don't know if this will make a significant difference, but instead setting PBSSRow[I].Width and PBSSRow[I].Top separately, make one call to PBSSRow[I].SetBounds instead. This will save you one Resize event for that SubComponent.
I am trying to color the background of a TComboBox with VCL styles enabled like the way its described in this article but its not working.
http://theroadtodelphi.wordpress.com/2012/02/06/changing-the-color-of-edit-controls-with-vcl-styles-enabled/
Depending of your Delphi version you must
Delphi XE2
For Delphi XE2 you must write a Style Hook
uses
Vcl.Styles,
Vcl.Themes;
type
TComboBoxStyleHookExt= class(TComboBoxStyleHook)
procedure UpdateColors;
strict protected
procedure WndProc(var Message: TMessage); override;
public
constructor Create(AControl: TWinControl); override;
end;
TWinControlClass= class(TWinControl);
{ TComboBoxStyleHookExt }
constructor TComboBoxStyleHookExt.Create(AControl: TWinControl);
begin
inherited;
UpdateColors;
end;
procedure TComboBoxStyleHookExt.UpdateColors;
const
ColorStates: array[Boolean] of TStyleColor = (scComboBoxDisabled, scComboBox);
FontColorStates: array[Boolean] of TStyleFont = (sfComboBoxItemDisabled, sfComboBoxItemNormal);
var
LStyle: TCustomStyleServices;
begin
if Control.Enabled then }//use the control colors
begin
Brush.Color := TWinControlClass(Control).Color;
FontColor := TWinControlClass(Control).Font.Color;
end
else
begin //if not enabled. use the current style colors
LStyle := StyleServices;
Brush.Color := LStyle.GetStyleColor(ColorStates[Control.Enabled]);
FontColor := LStyle.GetStyleFontColor(FontColorStates[Control.Enabled]);
end;
end;
procedure TComboBoxStyleHookExt.WndProc(var Message: TMessage);
begin
case Message.Msg of
WM_CTLCOLORMSGBOX..WM_CTLCOLORSTATIC,
CN_CTLCOLORMSGBOX..CN_CTLCOLORSTATIC:
begin
UpdateColors;
SetTextColor(Message.WParam, ColorToRGB(FontColor));
SetBkColor(Message.WParam, ColorToRGB(Brush.Color));
Message.Result := LRESULT(Brush.Handle);
Handled := True;
end;
CM_ENABLEDCHANGED:
begin
UpdateColors;
Handled := False;
end
else
inherited WndProc(Message);
end;
end;
initialization
TStyleManager.Engine.RegisterStyleHook(TComboBox, TComboBoxStyleHookExt);
Delphi XE3/XE4
Simply remove the seClient value from the StyleElements propertty
ComboBox1.StyleElements:=[seFont, seBorder];
ComboBox2.StyleElements:=[seFont, seBorder];
ComboBox3.StyleElements:=[seFont, seBorder];
I'm trying to display a truly alpha blended TPanel in Delphi XE2. I've found quite a few attempts online, but none of them work correctly.
What I'm trying to achieve is a 'semi modal' form. A form that is displayed over the top of other controls with a faded background in a similar manner to that seen in web browsers.
I've got it working in a basic form, but it suffers from the following problems:
A large amount of flicker when resizing the panel.
If a control is moved over the top of the panel it leaves a trail.
Here's my efforts thus far (based on some code I found 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.
Can anybody help me with the problems or point me to an alpha blend panel that already exists?
Thanks for all your suggestions. I've taken the input and created a new component that does exactly what I need. Here's what it looks like:
The comment that pointed me in the right direction was the one by NGLN that I upvoted. If you post it as the answer I'll accept it.
I tried to add the component code to this answer, but StackOverflow wouldn't format it correctly. However, you can download the source and a full demo application here.
The component provides the following functionality:
The semi modal form is a child of the main form. This means that it
can be tabbed to just like the other controls.
The overlay area is drawn correctly with no artefacts.
The controls under the overlay area are automatically disabled.
The semi modal form/overlay can be shown/hidden if required e.g.
switching tabs.
A SemiModalResult is passed back in an event.
There are still a number of small issues that I would like to iron out. If anybody knows how to fix them, please let me know.
When the parent form is moved or resized it needs to call the
ParentFormMoved procedure. This allows the component to
resize/reposition the overlay form. Is there any way to hook into
the parent form and detect when it is moved?
If you mimimise the main form, then restore it, the overlay form appears immediately, then the main form is animated back to it's previous position. Is there a way to detect when the main form has finished animating?
The rounded corners of the semi modal window are not too pretty. I'm
not sure there's much that can be done about this as it's down to the
rectangular region.
Your code does not show the form modally, and I wonder why you would not. But then, maybe I do not understand the term semi modal.
In any case, I think the idea to create a half-transparent form on which to show the actual dialog will do just fine:
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;
Usage:
procedure TForm1.Button1Click(Sender: TObject);
begin
FDialog := TForm2.Create(Self);
try
if ShowObviousModal(FDialog) = mrOk then
Caption := 'OK';
finally
FDialog.Free;
end;
end;
How can I reserve one edge of the desktop with Delphi? Something like the Vista Sidebar does.
What you want is called an application desktop toolbar
You must use the TAppBarData Object declared in the ShellAPI unit and the SHAppBarMessage function.
See this simple example.
type
TApplicationTaskBar = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
procedure CreateParams(var Params: TCreateParams); override;
public
{ Public declarations }
end;
var
ApplicationTaskBar: TApplicationTaskBar;
implementation
{$R *.dfm}
Uses
ShellAPI;
procedure TApplicationTaskBar.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.ExStyle := Params.ExStyle or WS_EX_TOOLWINDOW;
Params.Style := (Params.Style OR WS_POPUP) AND (NOT WS_DLGFRAME); //Remove title Bar
end;
procedure TApplicationTaskBar.FormCreate(Sender: TObject);
var
MyTaskBar : TAppBarData;
begin
GlassFrame.Enabled :=True;//Activate Glass , optional
GlassFrame.SheetOfGlass :=True;//optional
Left:=0;
Top :=0;
Width := 300;
Height:= Screen.Height;
FillChar(MyTaskBar, SizeOf(TAppBarData), 0);
MyTaskBar.cbSize := SizeOf(TAppBarData);
MyTaskBar.hWnd := Handle;
MyTaskBar.uCallbackMessage := WM_USER+777; //Define my own Mesaage
MyTaskBar.uEdge := ABE_LEFT;
MyTaskBar.rc := Rect(0, 0, Width, Height);
SHAppBarMessage(ABM_NEW, MyTaskBar);
SHAppBarMessage(ABM_ACTIVATE, MyTaskBar);
SHAppBarMessage(ABM_SETPOS, MyTaskBar);
Application.ProcessMessages;
end;
procedure TApplicationTaskBar.FormDestroy(Sender: TObject);
var
MyTaskBar : TAppBarData;
begin
FillChar(MyTaskBar, SizeOf(TAppBarData), 0);
MyTaskBar.cbSize := SizeOf(TAppBarData);
MyTaskBar.hWnd := Self.Handle;
SHAppBarMessage(ABM_Remove, MyTaskBar);
end;
Check this links
SHAppBarMessage
ABM_ACTIVATE
ABM_SETPOS
ABM_NEW
Bye.