Toggle Delphi Label color with Firemonkey - delphi

With VCL I can do this:
procedure TForm1.FormCreate(Sender: TObject);
begin
Label1.Color := clBlue;
Label1.Font.Color := clYellow;
label1.Caption := ' My Label '
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Label1.Color = clBlue then
begin
Label1.Color := clYellow;
Label1.Font.Color := clBlue
end
else
begin
Label1.Color := clBlue;
Label1.Font.Color := clYellow
end
end;
As you can see, the color of the label background and the text toggles from blue to yellow and vice-versa.
I want to do the same with Firemonkey but, all the search I made only says that FMX labels has no background color (I don't understand why),
and don't give me a effetive clue how to do the same thing as in VCL.
Can someone write here the equivalent FMX code snippet?
Thank you.

In Firemonkey many controls do not have a color. Instead you're supposed to layer controls out of different components.
In this case if you want a background use a TRectangle.
In the designer Delphi insists that you cannot have a label be parented by a rectangle, but this if of course not true, in FMX any control can parent any other.
Just use the structure pane to drag the label on top of the rectangle and voila label and rectangle are joined together.
The equivalent code to the above would look something like this.
unit Unit45;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs,
FMX.Controls.Presentation, FMX.StdCtrls, FMX.Objects;
type
TForm45 = class(TForm)
Rectangle1: TRectangle;
Label1: TLabel;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
Rects: array of TRectangle;
Labels: array of TLabel;
public
{ Public declarations }
end;
var
Form45: TForm45;
implementation
{$R *.fmx}
uses
System.UIConsts;
procedure TForm45.Button1Click(Sender: TObject);
var
i: integer;
begin
for i:= Low(Rects) to High(Rects) do begin
if Rects[i].Fill.Color <> claBlue then
Rects[i].Fill.Color:= claBlue
else Rects[i].Fill.Color:= claYellow;
end;
end;
procedure TForm45.FormCreate(Sender: TObject);
var
i: integer;
begin
SetLength(Rects,2);
SetLength(Labels,2);
for i:= 0 to 1 do begin
Rects[i]:= TRectangle.Create(self);
Rects[i].Parent:= self;
Labels[i]:= TLabel.Create(self);
Labels[i].Parent:= Rects[i];
Rects[i].Width:= Rectangle1.Width;
Rects[i].Height:= Rectangle1.Height;
Rects[i].Position.y:= 0 + i * Rects[i].Height;
Rects[i].Position.x:= 0 + i * Rects[i].Width;
Rects[i].Stroke.Kind:= TBrushKind.None;
Labels[i].AutoSize:= true;
Labels[i].Text:= 'Test'+IntToStr(i+1);
Labels[i].Position:= Label1.Position;
end;
end;
end.
Note that I've done the construction of the labels and rects in runtime, but you can do this in design time as well.
The color constants in FMX have changed from the VCL, see: http://docwiki.embarcadero.com/RADStudio/Seattle/en/Colors_in_FireMonkey

As an alternative, you can create a custom style for your TLabel component:
right-click the Label ("LabelXX") and select "Edit Custom Style...";
add a "TRectangle" component from the "Tool Palette" to the new style created ("LabelXXStyle1");
select the new "Rectangle1Style" object and send it to back (Edit -> "Send to Back");
Set the "Rectangle1Style" properties:
"Align" : "Client";
"Fill / Bitmap / Color" : any background color;
Apply changes (close the "Style Designer").
Set the "StyleLookup" property of the other TLabel(s) you need to "LabelXXStyle1".

If you are interested, here is one of my samples:
function CreateLabel(
AOwner: TFmxObject; ARangeWidth, ARangeHeight, ASizeMin, ASizeMax: Integer;
AText: String; AColor: TAlphaColor): TLabel;
var
LFMXObj: TFMXObject;
LFontSize: Integer;
begin
Result := TLabel.Create(AOwner);
with Result do
begin
Parent := AOwner;
Text := AText;
ApplyStyleLookup;
LFMXObj := FindStyleResource('text');
if Assigned(LFMXObj) then
begin
LFontSize := ASizeMin + Random(ASizeMax - ASizeMin);
//TText(LFMXObj).Fill.Color := AColor; // XE2
TText(LFMXObj).Color := AColor;
TText(LFMXObj).Font.Size := LFontSize;
TText(LFMXObj).Font.Style := TText(LFMXObj).Font.Style + [TFontStyle.fsBold];
TText(LFMXObj).WordWrap := False;
TText(LFMXObj).AutoSize := True;
Canvas.Font.Assign(TText(LFMXObj).Font);
Position.X := Random(ARangeWidth - Round(Canvas.TextWidth(Text)));
Position.Y := Random(ARangeHeight - Round(Canvas.TextHeight(Text)));
end;
{
// test background label painting
with TRectangle.Create(Result) do
begin
Parent := AOwner;
Fill.Color := TAlphaColors.Lightgrey;
Fill.Kind := TBrushKind.bkSolid;
Width := Result.Canvas.TextWidth(Result.Text);
Height := Result.Canvas.TextHeight(Result.Text);
Position.X := Result.Position.X;
Position.Y := Result.Position.Y;
Result.BringToFront;
end;
}
AutoSize := True;
Visible := True;
end;
end;

Related

Delphi FMX TTreeView Argument out of range exception

Using Delphi 10.4.
I am hoping someone can explain what I am doing wrong with my FMX TTreeView that is causing an EArgumentOutOfRangeException. I am trying to create a custom TTreeViewItem class that allows me to associate some data with each node, as well as provide an in-place editor to allowing changing the node text.
The code below is a stripped down version of what I am doing. The FMX form has a TTreeview and two buttons on it, with the form's Onshow set to FormShow and the buttons set to the two button events.
The TVLinkTreeViewItem is my custom TTreeViewItem where I add a background and edit component for my in-place editor, which is displayed when a node is double clicked.
When you run the code as is, the program will throw the exception when the logic gets to the TreeView1.EndUpdate call at the end of the FormShow routine. The exception is thrown in FMX.Controls in the TControl.EndUpdate procedure.
If you comment out the ExpandAll call, the exception is not thrown, but if you mess with the expanding and collapsing of the nodes and resizing of the form, sooner or later the exception gets thrown. I left the ExpandAll line in the code below, as I assume the exception is being caused by the same error.
From what I can tell, the problem appears to be how I am setting up the fBackground and fEditor. If I don't call the AddObject routine and not set the Parent properties, I get no exception.
So can anybody tell me what I am doing wrong? Or is there a better way to do an in-place editor for the FMX TTreeViewItems component?
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.TreeView, FMX.Layouts, FMX.Controls.Presentation,
FMX.MultiView, FMX.Edit, FMX.Objects, FMX.StdCtrls;
type
TForm1 = class(TForm)
TreeView1: TTreeView;
Button1: TButton;
Button2: TButton;
procedure FormShow(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
type
TVLinkTreeViewItem = class(TTreeViewItem)
private
fData: string;
fEditor: TEdit;
fBackground: TRectangle;
procedure TreeViewItem1DblClick(Sender: TObject);
procedure EditorExit(Sender: TObject);
procedure EditorKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
public
property Editor: TEdit read fEditor write fEditor;
property Data: string read fData write fData;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TreeView1.ExpandAll;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
TreeView1.CollapseAll;
end;
procedure TForm1.FormShow(Sender: TObject);
var
I, c, r, s: Integer;
vNode1,
vNode2,
vNode3,
vNode4: TVLinkTreeViewItem;
begin
TreeView1.BeginUpdate;
TreeView1.Clear;
for I := 0 to 4 do
begin
vNode1 := TVLinkTreeViewItem.Create(TreeView1);
vNode1.Text := 'Level 1 - '+ IntToStr(I);
TreeView1.AddObject(vNode1);
for c := 0 to 4 do
begin
vNode2 := TVLinkTreeViewItem.Create(vNode1);
vNode2.Text := 'Level 2 - '+ IntToStr(c);
vNode1.AddObject(vNode2);
for r := 0 to 4 do
begin
vNode3 := TVLinkTreeViewItem.Create(vNode2);
vNode3.Text := 'Level 3 - '+ IntToStr(r);
vNode2.AddObject(vNode3);
// for s := 0 to 4 do
// begin
// vNode4 := TVLinkTreeViewItem.Create(vNode3);
// vNode4.Text := 'Level 4 - '+ IntToStr(s);
// vNode3.AddObject(vNode4);
// end;
end;
end;
end;
//ExpandAll works when no parent is set for fBackGround and fEditor is not set in "TVLinkTreeViewItem.Create" below"
//If the Parents are set below, ExpandAll/EndUpdate causes "Augument out of range" exception.
TreeView1.ExpandAll;
treeView1.EndUpdate;
end;
{ TVLinkTreeViewItem }
constructor TVLinkTreeViewItem.Create(AOwner: TComponent);
begin
inherited;
fData := '';
fBackground := TRectangle.Create(AOwner);
//When ExpandAll is not called in FormShow,
// Calling "AddObject" or setting parent, as shown below, make all the code work,
// but will get intermident "Augument out of range" exceptions when resizing form,
// or when expanding or collapsing nodes using the buttons.
self.AddObject(fBackGround);
//fBackGround.Parent := self;
fBackGround.Visible := false;
fEditor := TEdit.Create(AOwner);
fBackGround.AddObject(fEditor);
//fEditor.Parent := fBackGround;
fEditor.Visible := false;
fEditor.Align := TAlignLayout.Client;
fEditor.OnKeyDown := EditorKeyUp;
self.OnDblClick := TreeViewItem1DblClick;
fEditor.OnExit := EditorExit;
end;
destructor TVLinkTreeViewItem.Destroy;
begin
inherited;
end;
procedure TVLinkTreeViewItem.TreeViewItem1DblClick(Sender: TObject);
begin
fBackGround.Visible := true;
fBackGround.Width := self.Width - 20;
fBackGround.Height := self.Height;
fBackGround.Position.X := 20;
fEditor.Enabled := true;
fEditor.Visible := true;
fEditor.Opacity := 1;
fBackGround.BringToFront;
fEditor.BringToFront;
fEditor.Text := Text;
fEditor.SetFocus;
fEditor.SelectAll;
end;
procedure TVLinkTreeViewItem.EditorKeyUp(Sender: TObject; var Key: Word; var KeyChar: Char; Shift: TShiftState);
begin
inherited;
if Key = vkReturn then
begin
Text := fEditor.Text;
fBackGround.Visible := false;
fEditor.Enabled := false;
end
else if Key in [vkEscape, vkCancel, vkTab, vkHardwareBack] then
begin
fBackGround.Visible := false;
fEditor.Enabled := false;
end;
end;
procedure TVLinkTreeViewItem.EditorExit(Sender: TObject);
begin
fBackGround.Visible := false;
fEditor.Enabled := false;
fEditor.Visible := false;
end;
end.
Here's the fmx content:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 480
ClientWidth = 640
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnShow = FormShow
DesignerMasterStyle = 0
object TreeView1: TTreeView
Align = Left
Size.Width = 269.000000000000000000
Size.Height = 480.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
Viewport.Width = 265.000000000000000000
Viewport.Height = 476.000000000000000000
end
object Button1: TButton
Position.X = 356.000000000000000000
Position.Y = 68.000000000000000000
TabOrder = 2
Text = 'Expand'
OnClick = Button1Click
end
object Button2: TButton
Position.X = 354.000000000000000000
Position.Y = 102.000000000000000000
TabOrder = 1
Text = 'Collapse'
OnClick = Button2Click
end
end

FireMonkey tRectangle with tLabel child

I am coding a custom control based on tRectangle:
tMyRect = class (tRectangle)
On the tMyRect Constructor, I create a tLabel:
fRectLabel := tLabel.Create (Self);
and then set some properties for it.
At runtime, the tLabel is not showed according to the properties settings, neither responds to the speedkey.
Follows the complete code:
unit frmMyRect;
interface
uses FMX.Controls, FMX.Controls.Presentation, FMX.Forms, FMX.Layouts,
FMX.Objects, FMXFMX.StdCtrls, FMX.Types,System.Classes, System.UITypes;
type
tfrmMyRect = class (tForm)
procedure FormCreate (Sender: tObject);
end;
tMyRect = class (tRectangle)
fRectLabel : tLabel;
constructor Create (aOwner: tComponent);
end;
var formMyRect: tfrmMyRect;
implementation
{$R *.fmx}
var MyRect : tMyRect;
procedure tformMyRect.FormCreate (Sender: tObject);
begin
MyRect := tMyRect.Create (Self);
MyRect.Parent := frmMyRect;
end; { FormCreate }
constructor tMyRect.Create (aOwner: tComponent);
begin
inherited;
Align := tAlignLayout.Center;
CanFocus := True;
Height := 23;
Width := 80;
fRectLabel := tLabel.Create (Self);
with fRectLabel do begin
Align := tAlignLayout.Center;
AutoSize := True;
FocusControl := Self;
HitTest := True;
Parent := Self;
Text := 'Labe&l';
with TextSettings do begin
FontColor := TAlphaColorRec.Blue;
WordWrap := False;
Font.Style := [TFontStyle.fsBold];
end;
end;
end; { Create }
end.
I appreciate if someone can clarify why the tLabel does not behave as expected.
You need to alter the StyleSettings property of the TLabel so that the styling system does not apply those that you have changed, e.g.:
StyledSettings := StyledSettings - [TStyledSetting.FontColor, TStyledSetting.Style];
As to the "neither responds to the speedkey" part, you'll need to clarify what you mean, as you have not shown code related to that

How to get a windows 10 style transparent border

I've been experimenting to see if I can get the same effect with a custom control with no luck.
The issue is, I'm wanting to make a resizable panel like component derived from Tcustomcontrol.
I can create a single pixel border with WS_BORDER and then use WMNCHitTest to detect the edges. But if the control contains another control aligned to alclient, then the mouse messages go to that contained component rather than the containing panel. So at best, the resizing cursors only work when they are precisely over the single pixel border.
Changing to WS_THICKFRAME obviously works but makes an ugly visible border.
I noticed that WIN10 forms have an invisible thick border with just a single pixel line on the inner edges. So the resizing cursors work outside the visible frame for about 6 to 8 pixels making it much easier to select.
Any ideas on how they are achieving that effect and can it be easily duplicated in delphi vcl controls?
You don't need borders that are meant to be used with top-level windows, handle WM_NCCALCSIZE to deflate your client area:
procedure TSomeControl.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
inherited;
InflateRect(Message.CalcSize_Params.rgrc0, -FBorderWidth, -FBorderWidth);
end;
where FBorderWidth is the supposed padding around the control.
Handle WM_NCHITTEST to resize with the mouse from borders.
procedure TSomeControl.WMNCHitTest(var Message: TWMNCHitTest);
var
Pt: TPoint;
begin
inherited;
Pt := ScreenToClient(Point(Message.XPos, Message.YPos));
if Pt.X < 0 then
Message.Result := HTLEFT;
...
Of course you have to paint the borders to your liking.
Here's my full test unit:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
extctrls;
type
TSomeControl = class(TCustomControl)
private
FBorderWidth: Integer;
protected
procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
public
constructor Create(AOwner: TComponent); override;
end;
{ TSomeControl }
constructor TSomeControl.Create(AOwner: TComponent);
begin
inherited;
FBorderWidth := 5;
ControlStyle := ControlStyle + [csAcceptsControls];
end;
procedure TSomeControl.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
inherited;
InflateRect(Message.CalcSize_Params.rgrc0, -FBorderWidth, -FBorderWidth);
end;
procedure TSomeControl.WMNCHitTest(var Message: TWMNCHitTest);
var
Pt: TPoint;
begin
inherited;
Pt := ScreenToClient(Point(Message.XPos, Message.YPos));
if Pt.X < 0 then
Message.Result := HTLEFT;
if Pt.Y < 0 then
Message.Result := HTTOP;
if Pt.X > ClientWidth then
Message.Result := HTRIGHT;
if Pt.Y > ClientHeight then
Message.Result := HTBOTTOM;
end;
procedure TSomeControl.WMNCPaint(var Message: TWMNCPaint);
var
DC: HDC;
begin
DC := GetWindowDC(Handle);
SelectClipRgn(DC, 0);
SelectObject(DC, GetStockObject(BLACK_PEN));
SelectObject(DC, GetStockObject(GRAY_BRUSH));
Rectangle(DC, 0, 0, Width, Height);
ReleaseDC(Handle, DC);
end;
//---------------------------------------
procedure TForm1.Button1Click(Sender: TObject);
var
C: TSomeControl;
P: TPanel;
begin
C := TSomeControl.Create(Self);
C.SetBounds(30, 30, 120, 80);
C.Parent := Self;
P := TPanel.Create(Self);
P.Parent := C;
P.Align := alClient;
end;
end.

How to enforce VCL style overrides when dynamically creating components?

In Delphi XE2 I have successfully created overrides for the VCL Styles for a custom component class I have created. What I have found though is that the styles do not appear to apply during runtime creation of the controls.
To be specific I have extended TPanel and am filling a TScrollBox with dynamically created Panels, setting each to a specific color. I also use the API to suspend redraws on the ScrollBox during the creation process.
When the loading is complete, I am left with TPanels set to clWindow (visually) but when I drag and drop the TPanel to another location/control the colors I set in code "kick in". So something is not letting/allowing those colors to apply... or the Panels simply are not refreshing.
So I'm not quite sure if there is a "refresh" I need to call with VCL Style overrides on dynamic component creation, or if the suspension of redraws on TScrollBox are causing interference with the color not updating on the Panel when created.. since it is a child of the suspended ScrollBox.
I'm wondering if there is just a simple & known "gotcha" I am overlooking with what I am trying to do.
I've stripped down the project to bare essentials and it still has the issue.
This is a simple extension of TPanel adding a label.
unit InfluencePanel;
interface
uses
System.SysUtils, System.Classes, Vcl.Forms, Vcl.Controls, Vcl.StdCtrls, Vcl.ExtCtrls,
Vcl.Graphics;
type
TInfluencePanel = class(TPanel)
private
{ Private declarations }
oCaptionLabel : TLabel;
FLabelCaption : String;
procedure SetLabelCaption(sCaption : String);
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
property LabelCaption : string read FLabelCaption write SetLabelCaption;
published
{ Published declarations }
end;
procedure Register;
implementation
constructor TInfluencePanel.Create(AOwner: TComponent);
begin
inherited;
oCaptionLabel := TLabel.Create(Self);
with oCaptionLabel do
begin
Caption := 'Caption';
Top := 0;
Left := 0;
Align := alTop;
WordWrap := True;
Parent := Self;
end;
end;
procedure TInfluencePanel.SetLabelCaption(sCaption: string);
begin
FLabelCaption := sCaption;
if oCaptionLabel <> nil then oCaptionLabel.Caption := FLabelCaption;
end;
procedure Register;
begin
RegisterComponents('Influence Elements', [TInfluencePanel]);
end;
end.
This is the simple project that should show the issue. Button 1 loads five instances of the TInfluencePanel into ScrollBox1. They appear with the default windows color and no style instead of the color in code. Button2 moves the controls to ScrollBox2 where they appear with the coded colors. This has all the suspended redraws taken out, etc.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.Themes, InfluencePanel;
type
TInfluencePanelStyleHookColor = class(TEditStyleHook)
private
procedure UpdateColors;
protected
procedure WndProc(var Message: TMessage); override;
public
constructor Create(AControl: TWinControl); override;
end;
type
TForm1 = class(TForm)
ScrollBox1: TScrollBox;
ScrollBox2: TScrollBox;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
Vcl.Styles;
type
TWinControlH= class(TWinControl);
constructor TInfluencePanelStyleHookColor.Create(AControl: TWinControl);
begin
inherited;
UpdateColors;
end;
procedure TInfluencePanelStyleHookColor.UpdateColors;
var
LStyle: TCustomStyleServices;
begin
if Control.Enabled then
begin
Brush.Color := TWinControlH(Control).Color;
FontColor := TWinControlH(Control).Font.Color;
end
else
begin
LStyle := StyleServices;
Brush.Color := LStyle.GetStyleColor(scEditDisabled);
FontColor := LStyle.GetStyleFontColor(sfEditBoxTextDisabled);
end;
end;
procedure TInfluencePanelStyleHookColor.WndProc(var Message: TMessage);
begin
case Message.Msg of
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;
procedure TForm1.Button1Click(Sender: TObject);
var
iPanel, iLastPosition : Integer;
oPanel : TInfluencePanel;
begin
iLastPosition := 0;
for iPanel := 1 to 5 do
begin
oPanel := TInfluencePanel.Create(ScrollBox1);
with oPanel do
begin
Align := alLeft;
Left := iLastPosition;
Width := 90;
Parent := ScrollBox1;
Color := RGB(200,100,iPanel*10);
LabelCaption := 'My Panel ' + IntToStr(iPanel);
Margins.Right := 5;
AlignWithMargins := True;
end;
iLastPosition := iLastPosition + 90;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
iPanel : Integer;
begin
for iPanel := ScrollBox1.ControlCount - 1 downto 0 do
begin
if ScrollBox1.Controls[iPanel].ClassType = TInfluencePanel then
TInfluencePanel(ScrollBox1.Controls[iPanel]).Parent := ScrollBox2;
end;
end;
initialization
TStyleManager.Engine.RegisterStyleHook(TInfluencePanel,TInfluencePanelStyleHookColor);
end.
Your Style hook has not effect in the paint process because The TPanel doesn't use a style hook to draw the control. you must override the paint method in your component like so.
unit InfluencePanel;
interface
uses
System.SysUtils, System.Classes, Vcl.Forms, Vcl.Controls, Vcl.StdCtrls, Vcl.ExtCtrls,
Vcl.Graphics;
type
TInfluencePanel = class(TPanel)
private
{ Private declarations }
oCaptionLabel : TLabel;
FLabelCaption : String;
procedure SetLabelCaption(sCaption : String);
protected
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
property LabelCaption : string read FLabelCaption write SetLabelCaption;
published
{ Published declarations }
end;
procedure Register;
implementation
uses
Winapi.Windows,
System.Types,
Vcl.Themes;
constructor TInfluencePanel.Create(AOwner: TComponent);
begin
inherited;
oCaptionLabel := TLabel.Create(Self);
with oCaptionLabel do
begin
Caption := 'Caption';
Top := 0;
Left := 0;
Align := alTop;
WordWrap := True;
Parent := Self;
end;
end;
procedure TInfluencePanel.SetLabelCaption(sCaption: string);
begin
FLabelCaption := sCaption;
if oCaptionLabel <> nil then oCaptionLabel.Caption := FLabelCaption;
end;
procedure TInfluencePanel.Paint;
const
Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);
VerticalAlignments: array[TVerticalAlignment] of Longint = (DT_TOP, DT_BOTTOM, DT_VCENTER);
var
Rect: TRect;
LColor: TColor;
LStyle: TCustomStyleServices;
LDetails: TThemedElementDetails;
TopColor : TColor;
BottomColor : TColor;
LBaseColor : TColor;
LBaseTopColor : TColor;
LBaseBottomColor: TColor;
Flags: Longint;
procedure AdjustColors(Bevel: TPanelBevel);
begin
TopColor := LBaseTopColor;
if Bevel = bvLowered then
TopColor := LBaseBottomColor;
BottomColor := LBaseBottomColor;
if Bevel = bvLowered then
BottomColor := LBaseTopColor;
end;
begin
Rect := GetClientRect;
LBaseColor := Color;//use the color property value to get the background color.
LBaseTopColor := clBtnHighlight;
LBaseBottomColor := clBtnShadow;
LStyle := StyleServices;
if LStyle.Enabled then
begin
LDetails := LStyle.GetElementDetails(tpPanelBevel);
if LStyle.GetElementColor(LDetails, ecEdgeHighLightColor, LColor) and (LColor <> clNone) then
LBaseTopColor := LColor;
if LStyle.GetElementColor(LDetails, ecEdgeShadowColor, LColor) and (LColor <> clNone) then
LBaseBottomColor := LColor;
end;
if BevelOuter <> bvNone then
begin
AdjustColors(BevelOuter);
Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
end;
if not (LStyle.Enabled and (csParentBackground in ControlStyle)) then
Frame3D(Canvas, Rect, LBaseColor, LBaseColor, BorderWidth)
else
InflateRect(Rect, -Integer(BorderWidth), -Integer(BorderWidth));
if BevelInner <> bvNone then
begin
AdjustColors(BevelInner);
Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
end;
with Canvas do
begin
if not LStyle.Enabled or not ParentBackground then
begin
Brush.Color := LBaseColor;
FillRect(Rect);
end;
if ShowCaption and (Caption <> '') then
begin
Brush.Style := bsClear;
Font := Self.Font;
Flags := DT_EXPANDTABS or DT_SINGLELINE or
VerticalAlignments[VerticalAlignment] or Alignments[Alignment];
Flags := DrawTextBiDiModeFlags(Flags);
if LStyle.Enabled then
begin
LDetails := LStyle.GetElementDetails(tpPanelBackground);
if not LStyle.GetElementColor(LDetails, ecTextColor, LColor) or (LColor = clNone) then
LColor := Font.Color;
LStyle.DrawText(Handle, LDetails, Caption, Rect, TTextFormatFlags(Flags), LColor)
end
else
DrawText(Handle, Caption, -1, Rect, Flags);
end;
end;
end;
procedure Register;
begin
RegisterComponents('Influence Elements', [TInfluencePanel]);
end;
end.
Also in the runtime creation set the ParentBackground property to False
for iPanel := 1 to 5 do
begin
oPanel := TInfluencePanel.Create(ScrollBox1);
with oPanel do
begin
Align := alLeft;
Left := iLastPosition;
Width := 90;
Parent := ScrollBox1;
ParentBackground:=False;// <----
Color := RGB(200,100,iPanel*20);
LabelCaption := 'My Panel ' + IntToStr(iPanel);
Margins.Right := 5;
AlignWithMargins := True;
end;
iLastPosition := iLastPosition + 90;
end;

Is it possible to Alpha Blend a VCL control on a TForm?

Is it possible to Alpha Blend or implement a similar effect for a VCL control on a TForm?
For example, consider the following screenshot where two TPanels are placed on a TForm in addition to other controls. Both the panels are made draggable (See How to Move and Resize Controls at Run Time).
Now, is it possible to make these panels translucent while dragging so that you can see what is underneath? (as shown in the second image which was produced by image manipulation)
The VCL gives you the opportunity to specify a drag image list to be used during drag-and-drop, here's a quick example:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;
type
TPanel = class(Vcl.ExtCtrls.TPanel)
protected
function GetDragImages: TDragImageList; override;
end;
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
Button3: TButton;
CheckBox1: TCheckBox;
Edit1: TEdit;
Label1: TLabel;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
procedure FormCreate(Sender: TObject);
procedure FormDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure PanelStartDrag(Sender: TObject; var DragObject: TDragObject);
procedure PanelEndDrag(Sender, Target: TObject; X, Y: Integer);
private
FDragImages: TDragImageList;
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TPanel }
function TPanel.GetDragImages: TDragImageList;
begin
Result := (Owner as TForm1).FDragImages;
end;
type
TControlProc = reference to procedure(Control: TControl);
procedure IterateControls(Control: TControl; Proc: TControlProc);
var
I: Integer;
begin
if Assigned(Control) then
Proc(Control);
if Control is TWinControl then
for I := 0 to TWinControl(Control).ControlCount - 1 do
IterateControls(TWinControl(Control).Controls[I], Proc);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
FDragImages := nil;
// set display drag image style
IterateControls(Self,
procedure(Control: TControl)
begin
Control.ControlStyle := Control.ControlStyle + [csDisplayDragImage];
end
);
end;
procedure TForm1.FormDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := Source is TPanel;
end;
procedure TForm1.PanelEndDrag(Sender, Target: TObject; X, Y: Integer);
begin
FreeAndNil(FDragImages);
end;
procedure TForm1.PanelStartDrag(Sender: TObject; var DragObject: TDragObject);
var
Image: TBitmap;
begin
if not (Sender is TPanel) then
Exit;
Image := TBitmap.Create;
try
Image.PixelFormat := pf32bit;
Image.Width := TControl(Sender).Width;
Image.Height := TControl(Sender).Height;
TPanel(Sender).PaintTo(Image.Canvas, 0, 0);
FDragImages := TDragImageList.Create(nil);
FDragImages.Width := Image.Width;
FDragImages.Height := Image.Height;
FDragImages.SetDragImage(FDragImages.Add(Image, nil), 0, 0);
FDragImages.ShowDragImage;
except
Image.Free;
FreeAndNil(FDragImages);
raise;
end;
end;
end.
You can do this in Delphi, too. The basic idea is to place the control into an autosized, borderles form with alpha blending enabled.
According to the article you linked to, in the MouseDown event add the following lines:
P := TWinControl(Sender).ClientToScreen(Point(0,0));
frm := TForm.Create(nil);
TWinControl(Sender).Parent := frm;
frm.BorderStyle := bsNone;
frm.AlphaBlend := true;
frm.AlphaBlendValue := 128;
frm.AutoSize := true;
frm.Left := P.X;
frm.Top := P.Y;
frm.Position := poDesigned;
frm.Show;
In the MouseMove event set the Left and Top properties of the controls parent:
GetCursorPos(newPos);
Screen.Cursor := crSize;
Parent.Left := Parent.Left - oldPos.X + newPos.X;
Parent.Top := Parent.Top - oldPos.Y + newPos.Y;
oldPos := newPos;
and in the MouseUp event release the form, set the controls parent back to the original parent and translate the screen position to the new position relative to it:
frm := TWinControl(Sender).Parent;
P := Point(frm.Left, frm.Top);
P := ScreenToClient(P);
TWinControl(Sender).Parent := Self;
TWinControl(Sender).Left := P.X;
TWinControl(Sender).Top := P.Y;
frm.Free;
Screen.Cursor := crDefault;
ReleaseCapture;
inReposition := False;
To implement a drag operation displaying the image of the control, you must create a TDragControlObject descendent and implement the GetDragImages method, from here you must ensure to add the csDisplayDragImage value to the ControlStyle property of the controls to drag.
You can find a very good article about this topic here Implementing Professional Drag & Drop In VCL/CLX Applications

Resources