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.
Related
I've changed my form to a borderless form, I just changed the BorderStyle property to bsNone, but now my application loses the windows anchor and some commands like
WIN + ↑ (Align the form Client) WIN + ↓ (Minimize the form) WIN + →(Align the form Right) WIN + ←(Align the form Left)
I've tried to set BorderStyle: bsSizeable and use the below code inside of the FormCreate, but this does not worked:
procedure TfrmBase.FormCreate(Sender: TObject);
begin
SetWindowLong(Handle
,GWL_STYLE
,GetWindowLong(Handle, GWL_STYLE)
AND (NOT WS_CAPTION)
AND (NOT WS_THICKFRAME)
);
Refresh;
FormColor := oLauncher.oCor;
end;
This results:
The image above is what I want, but the Windows commands that I already have mentioned don't work
Have any way to set the BorderStyle: bsNone and don't lose these commands?
EDITED
If I use the WS_THICKFRAME my form returns a little top border and the windows commands works well, but I don't want that top border.
EDITED 2
I got very close to the expected result, but have a little problem yet...
I put this on my FormCreate
SetWindowLong(Handle
,GWL_STYLE
,GetWindowLong(Handle, GWL_STYLE)
AND (NOT WS_CAPTION)
);
And I create the method
private
procedure WmNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE;
and then
procedure TfrmBase.WmNCCalcSize(var Msg: TWMNCCalcSize);
begin
inherited;
if Msg.CalcValidRects then
begin
InflateRect(Msg.CalcSize_Params.rgrc[0], 0, 6);
Msg.Result := 0;
end;
end;
I got this method here
Now the border has disappeared, but when my Form loses the focus, the top / bottom border is shown again....
How can I avoid this?
SOLVED
I left the border as BorderStyle: bsSizeable, then I did it:
private
procedure WmNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE;
[...]
procedure TfrmBase.WmNCCalcSize(var Msg: TWMNCCalcSize);
var
R: TRect;
begin
if not Msg.CalcValidRects then
R := PRect(Msg.CalcSize_Params)^;
inherited;
if Msg.CalcValidRects then
Msg.CalcSize_Params.rgrc0 := Msg.CalcSize_Params.rgrc1
else
PRect(Msg.CalcSize_Params)^ := R;
Msg.Result := 0;
end;
procedure TfrmBase.FormCreate(Sender: TObject);
begin
BorderStyle := bsNone;
SetWindowLong(Handle
,GWL_STYLE
,WS_CLIPCHILDREN or WS_OVERLAPPEDWINDOW
);
end;
procedure TfrmBase.FormShow(Sender: TObject);
begin
Width := (Width - 1);
end;
Solution at GitHUB
I've create a repository here
Some of the commands you refer to are system commands related to sizing of the window. That requires the thick frame, without it "WIN + right" and "WIN + left" won't work. Additionally you need the minimize box and the maximize box for the WIN + up/down commands to work.
Best is to start from scratch and include the styles you need, otherwise VCL might interfere. If there's a possibility of your form to be recreated, put styling in a CreateWnd override.
procedure TForm1.FormCreate(Sender: TObject);
begin
BorderStyle := bsNone;
SetWindowLong(Handle, GWL_STYLE, WS_CLIPCHILDREN or WS_OVERLAPPEDWINDOW);
end;
Then there's the frame that you don't want. In an edit in the question you inflate the client rectangle to get rid of it. Don't guess the frame width/height, do it like the below.
procedure TForm1.WMNCCalcSize(var Message: TWMNCCalcSize);
var
R: TRect;
begin
if not Message.CalcValidRects then
R := PRect(Message.CalcSize_Params)^;
inherited;
if Message.CalcValidRects then
Message.CalcSize_Params.rgrc0 := Message.CalcSize_Params.rgrc1
else
PRect(Message.CalcSize_Params)^ := R;
Message.Result := 0;
end;
Reading the documentation for the message is mandatory at this point, the parameters have different meanings at different stages, etc..
The above leaves a window without any non-client area at all. The client rectangle is equal to the window rectangle. Although the caption is not visible, you can activate the system menu by pressing Alt+Space. The problem is, the system insists on drawing activation state. Now it draws a frame in the client area!!
Get rid of it by intercepting WM_NCACTIVATE, you also need it to draw your title according to the activation status:
procedure TForm1.WMNCActivate(var Message: TWMNCActivate);
begin
if Message.Active then
// draw active caption
else
// draw incactive caption
// don't call inherited
end;
You might have to deal with some glitches, messing up with the window has consequences. In my test, the minimized form does not have an associated icon in the alt+tab dialog for instance.
Below is my test unit in full.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
protected
procedure WMNCActivate(var Message: TWMNCActivate); message WM_NCACTIVATE;
procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
BorderStyle := bsNone;
SetWindowLong(Handle, GWL_STYLE, WS_CLIPCHILDREN or WS_OVERLAPPEDWINDOW);
end;
procedure TForm1.WMNCActivate(var Message: TWMNCActivate);
begin
if Message.Active then
// draw active caption
else
// draw incactive caption
// don't call inherited
end;
procedure TForm1.WMNCCalcSize(var Message: TWMNCCalcSize);
var
R: TRect;
begin
if not Message.CalcValidRects then
R := PRect(Message.CalcSize_Params)^;
inherited;
if Message.CalcValidRects then
Message.CalcSize_Params.rgrc0 := Message.CalcSize_Params.rgrc1
else
PRect(Message.CalcSize_Params)^ := R;
Message.Result := 0;
end;
end.
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;
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;
I've implemented custom drag images with no problem.
I inherite a class from TDragControlObject and override its GetDragImages function and
add bitmap to TDragImageList, making the white pixels transparent.
It works, white pixels are invisible (transparent) but the remaining bitmap is not opaque.
Is there a way to change this behavior of dragobject?
You can use ImageList_SetDragCursorImage. This is normally used to provide a merged image of the drag image with a cursor image, and then, normally, you hide the real cursor to prevent confusion (showing two cursors).
The system does not blend the cursor image with the background as it does with the drag image. So, if you provide the same drag image as the cursor image, at the same offset, and do not hide the actual cursor, you'll end up with an opaque drag image with a cursor. (Similarly, an empty drag image could be used but I find the former design easier to implement.)
The below sample code (XE2) is tested with W7x64 and in a VM with XP.
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;
Button2: TButton;
procedure Button2MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure Button2StartDrag(Sender: TObject; var DragObject: TDragObject);
procedure Button2EndDrag(Sender, Target: TObject; X, Y: Integer);
private
FDragObject: TDragObject;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses
commctrl;
{$R *.dfm}
type
TMyDragObject = class(TDragObjectEx)
private
FDragImages: TDragImageList;
FImageControl: TWinControl;
protected
function GetDragImages: TDragImageList; override;
public
constructor Create(ImageControl: TWinControl);
destructor Destroy; override;
end;
constructor TMyDragObject.Create(ImageControl: TWinControl);
begin
inherited Create;
FImageControl := ImageControl;
end;
destructor TMyDragObject.Destroy;
begin
FDragImages.Free;
inherited;
end;
function TMyDragObject.GetDragImages: TDragImageList;
var
Bmp: TBitmap;
Pt: TPoint;
begin
if not Assigned(FDragImages) then begin
Bmp := TBitmap.Create;
try
Bmp.PixelFormat := pf32bit;
Bmp.Canvas.Brush.Color := clFuchsia;
// 2px margin at each side just to show image can have transparency.
Bmp.Width := FImageControl.Width + 4;
Bmp.Height := FImageControl.Height + 4;
Bmp.Canvas.Lock;
FImageControl.PaintTo(Bmp.Canvas.Handle, 2, 2);
Bmp.Canvas.Unlock;
FDragImages := TDragImageList.Create(nil);
FDragImages.Width := Bmp.Width;
FDragImages.Height := Bmp.Height;
Pt := Mouse.CursorPos;
MapWindowPoints(HWND_DESKTOP, FImageControl.Handle, Pt, 1);
FDragImages.DragHotspot := Pt;
FDragImages.Masked := True;
FDragImages.AddMasked(Bmp, clFuchsia);
finally
Bmp.Free;
end;
end;
Result := FDragImages;
end;
//--
procedure TForm1.Button2MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
(Sender as TWinControl).BeginDrag(False);
// OnStartDrag is called during the above call so FDragImages is
// assigned now.
// The below is the only difference with a normal drag image implementation.
ImageList_SetDragCursorImage(
(FDragObject as TMyDragObject).GetDragImages.Handle, 0, 0, 0);
end;
procedure TForm1.Button2StartDrag(Sender: TObject; var DragObject: TDragObject);
begin
DragObject := TMyDragObject.Create(Sender as TWinControl);
DragObject.AlwaysShowDragImages := True;
FDragObject := DragObject;
end;
end.
Screen shot for above code:
(Note that the actual cursor was crNoDrop but the capture software used the default one.)
If you want to see what the system really does with the images, change the above ImageList_SetDragCursorImage call to proide a hot spot, e.g.
ImageList_SetDragCursorImage(
(FDragObject as TMyDragObject).GetDragImages.Handle, 0, 15, 15);
// ShowCursor(False); // optional
now you'll be able to see both the semi-transparent and opaque images at the same time.
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