With other styles controls, I would normally add a background rectangle to a custom ListboxItem style and define a color animation with Trigger: IsMouseOver=true, but it does not work in this situation.
Only if I set HitTest := True for the background rectangle, then the hover animation works, but then the ListBox does not respond to clicks on the item, and you cannot select an item.
How do I add the hover effect to the ListBox?
I ran into the same problem a while ago.
The only workaround i could find is to skip the style and create your own listboxitem. Only thing is your text will disappear, so i added a label to display the text.
Its not the great, but it worked in my case
type
TMouseOverListBoxItem = class(TListBoxItem)
private
FBackGround: TRectangle;
FHoverAni: TColorAnimation;
FLabel: TLabel;
procedure BackgroundClicked(Sender: TObject);
protected
procedure DoTextChanged; override;
public
procedure AfterConstruction; override;
end;
procedure TMouseOverListBoxItem.AfterConstruction;
const
cStart = TAlphaColorRec.White;
cStop = TAlphaColorRec.Yellow;
begin
inherited;
// Create background
FBackGround := TRectangle.Create(Self);
FBackGround.Parent := Self;
FBackGround.Fill.Color := cStart;
FBackGround.Align := TAlignLayout.Contents;
FBackGround.HitTest := True;
FBackGround.Sides := [];
FBackGround.OnClick := BackgroundClicked;
// Create mouse over animation
FHoverAni := TColorAnimation.Create(FBackGround);
FHoverAni.Parent := FBackGround;
FHoverAni.Trigger := 'IsMouseOver=true';
FHoverAni.TriggerInverse := 'IsMouseOver=false';
FHoverAni.StartValue := cStart;
FHoverAni.StopValue := cStop;
FHoverAni.PropertyName := 'Fill.Color';
// Create label to show text. Background will hide original text
FLabel := TLabel.Create(FBackGround);
FLabel.Parent := FBackGround;
FLabel.Align := TAlignLayout.Client;
end;
procedure TMouseOverListBoxItem.BackgroundClicked(Sender: TObject);
begin
if Assigned(OnClick) then
OnClick(Self)
else if Assigned(ListBox.OnItemClick) then
ListBox.OnItemClick(ListBox, Self);
end;
procedure TMouseOverListBoxItem.DoTextChanged;
begin
inherited;
FLabel.Text := Self.Text;
end;
Related
I have a set of TImage instances layed out on a panel. The TImages represent icons (see attached screenshot). I would like to draw a red rectangle around a given TImage instance when the user selects it by clicking on it. Not sure how to proceed...
Edit: why am I not using a TToolbar? Reason 1: I don't like the default "look and feel" of the TToolbar and I want to have more control on it. Reason 2: This control is not really a TToolbar. It should rather be considered as a sort of "bookmark" element, which displays different text in the memo field depending on which "bookmark" is selected.
The accepted solution using Remy Lebeau's suggestion is shown below:
I would suggest using a TPaintBox instead of a TImage. Load your image into an appropriate TGraphic class (TBitmap, TIcon, TPNGImage, etc) and then draw it onto the TPaintBox in its OnPaint event. That is all a TImage really does (it holds a TGraphic that is drawn onto its Canvas when painted). You can then draw a red rectangle on top of the image when needed. For example:
procedure TMyForm.PaintBox1Click(Sender: TObject);
begin
PaintBox1.Tag := 1;
PaintBox1.Invalidate;
PaintBox2.Tag := 0;
PaintBox2.Invalidate;
end;
procedure TMyForm.PaintBox2Click(Sender: TObject);
begin
PaintBox1.Tag := 0;
PaintBox1.Invalidate;
PaintBox2.Tag := 1;
PaintBox2.Invalidate;
end;
procedure TMyForm.PaintBox1Paint(Sender: TObject);
begin
PaintBox1.Canvas.Draw(MyImage1, 0, 0);
if PaintBox1.Tag = 1 then
begin
PaintBox1.Canvas.Brush.Style := bsClear;
PaintBox1.Canvas.Pen.Color := clRed;
PaintBox1.Canvas.Rectangle(PaintBox1.ClientRect);
end;
end;
procedure TMyForm.PaintBox2Paint(Sender: TObject);
begin
PaintBox2.Canvas.Draw(MyImage2, 0, 0);
if PaintBox2.Tag = 1 then
begin
PaintBox2.Canvas.Brush.Style := bsClear;
PaintBox2.Canvas.Pen.Color := clRed;
PaintBox2.Canvas.Rectangle(PaintBox2.ClientRect);
end;
end;
Alternatively, you can derive a new class from TImage and override its virtual Paint() method to draw the rectangle after default drawing. For example:
type
TMyImage = class(TImage)
private
FShowRectangle: Boolean;
procedure SetShowRectangle(Value: Boolean);
protected
procedure Paint; override;
public
property ShowRectangle: Boolean read FShowRectangle write SetShowRectangle;
end;
procedure TMyImage.SetShowRectangle(Value: Boolean);
begin
if FShowRectangle <> Value then
begin
FShowRectangle := Value;
Invalidate;
end;
end;
type
TGraphicControlAccess = class(TGraphicControl)
end;
procedure TMyImage.Paint;
begin
inherited;
if FShowRectangle then
begin
with TGraphicControlAccess(Self).Canvas do
begin
Brush.Style := bsClear;
Pen.Color := clRed;
Rectangle(ClientRect);
end;
end;
end;
procedure TMyForm.MyImage1Click(Sender: TObject);
begin
MyImage1.ShowRectangle := true;
MyImage2.ShowRectangle := false;
end;
procedure TMyForm.MyImage2Click(Sender: TObject);
begin
MyImage1.ShowRectangle := false;
MyImage2.ShowRectangle := true;
end;
I would modify the proposals. there would be no problem with the objects on the form type the following :
TImage = class(ExtCtrls.TImage)
private
FShowRectangle: Boolean;
procedure SetShowRectangle(Value: Boolean);
protected
procedure Paint; override;
public
property ShowRectangle: Boolean read FShowRectangle write SetShowRectangle;
end;
I would recommend using a TRectangle. You can add an bitmap (bitmap, jpg, etc) via the Fill propery and set the Stroke property for the border.
You also can set the xRadius and yRadius properties for rounded borders.
When there is no data to show in ListView, it is better to show message as "no data is changed now", which should be drawed in a TLabel.
How to draw a TLabel in the ListView client area?
You don't need a TLabel for that.
On Vista and later, you can subclass the ListView to handle the LVN_GETEMPTYMARKUP notification.
uses
..., CommCtrl;
private
PrevWndProc: TWndMethod;
procedure TMyForm.FormCreate(Sender: TObject);
begin
PrevWndProc := ListView.WndProc;
ListView.WndProc := ListViewWndProc;
end;
procedure TMyForm.ListViewWndProc(var Message: TMessage);
begin
if Message.Msg = CN_NOTIFY then
begin
if TWMNotifyLV(Message).NMHdr.code = LVN_GETEMPTYMARKUP then
begin
with PNMLVEmptyMarkup(TWMNotifyLV(Message).NMHdr)^ do
begin
dwFlags := EMF_CENTERED;
StrLCopy(szMarkup, 'My message here', L_MAX_URL_LENGTH);
end;
Message.Result := 1;
Exit;
end;
end;
PrevWndProc(Message);
end;
The downside is you have little control over where the text appears (only whether it is left-justified or centered) or how it is formatted, and you cannot change the text dynamically (you would have to add at least one item and then remove it to trigger a new notification).
On earlier versions, or if you need more control over the text position/format/behavior, you can use the ListView's OnCustomDraw event instead. You can draw whatever you want on the ListView's Canvas within the area designated by a TRect provided by the event. If needed, you can use ListView_GetHeader() to determine if the ListView's column headers are visible, and if so then use GetWindowRect() to get the header's height so you can subtract it from the top of the TRect before drawing.
For example:
procedure TMyForm.ListViewCustomDraw(Sender: TCustomListView; const ARect: TRect; var DefaultDraw: Boolean);
var
R, Temp: TRect;
Wnd: HWND;
begin
if Sender.Items.Count <= 0 then
begin
R := ARect;
Wnd := ListView_GetHeader(Sender.Handle);
if Wnd <> 0 then
begin
GetWindowRect(Wnd, #Temp);
R.Top := R.Top + (Temp.Bottom-Temp.Top);
end;
R.Top := R.Top + 10;
DrawText(Sender.Canvas.Handle, 'My message here', -1, #R, DT_CENTER or DT_SINGLELINE);
end;
end;
I am working on a Delphi component which consists of a panel with some labels and buttons. It can look like this:
or like this:
depending on the setting of a property. Also, the layout of the labels changes depending on the length of the first one.
I have been prototyping this with a TFrame, and doing the layout calculations in the OnPaint method of the frame. What is the right place to do this in a component based on a TPanel? Or, more precisely, in a TCustomAdvPanel, which is what I'm deriving from. Does it work in an override for the Paint method, like so?
procedure TDateRangePicker.Paint;
const
hSpacing = 5;
begin
if FShowRefresh then
begin
btnRefresh.Visible := true;
btnRefresh.Left := Width - hSpacing - btnRefresh.Width;
btnClearDates.Left := btnRefresh.Left - hSpacing - btnClearDates.Width;
btnChooseDates.Left := btnClearDates.Left - hSpacing - btnChooseDates.Width;
end
else begin
btnRefresh.Visible := false;
btnClearDates.Left := Width - hSpacing - btnClearDates.Width;
btnChooseDates.Left := btnClearDates.Left - hSpacing - btnChooseDates.Width;
end;
lblRangeCaption.Left := hSpacing;
lblDateRange.Left := lblRangeCaption.Left + lblRangeCaption.Width + hSpacing;
inherited Paint;
end;
Definitely do not use the Paint method to re-position controls. In the worst case this keeps on triggering the Paint method again, and again... because, well: due to replacing controls, the panel needs to get repainted. Paint, and all equivalents, is only meant for drawing yourself.
On whén to implement your code: this should be done in the setter of the ShowRefresh property.
On how to implement your ShowRefresh property: of course you can move the controls around like you are doing now. You also might consider using Margins (Delphi XE) and aligning the buttons and labels. Then the property setters will become rather simple:
type
TDateRangePicker = class(TCustomPanel)
private
FChooseButton: TButton;
FClearButton: TButton;
FRefreshButton: TButton;
FLabel1: TLabel;
FLabel2: TLabel;
function GetLabel1Caption: String;
function GetRefreshButtonVisible: Boolean;
procedure SetLabel1Caption(const Value: String);
procedure SetRefreshButtonVisible(Value: Boolean);
public
constructor Create(AOwner: TComponent); override;
published
property RefreshButtonVisible: Boolean read GetRefreshButtonVisible
write SetRefreshButtonVisible default True;
property Label1Caption: String read GetLabel1Caption
write SetLabel1Caption;
end;
...
constructor TDateRangePicker.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FChooseButton := TButton.Create(Self);
FChooseButton.Caption := 'Choose';
FChooseButton.Align := alRight;
FChooseButton.AlignWithMargins := True;
FChooseButton.Margins.Left := 10;
FChooseButton.Parent := Self;
FClearButton := TButton.Create(Self);
FClearButton.Caption := 'Clear';
FClearButton.Align := alRight;
FClearButton.AlignWithMargins := True;
FClearButton.Margins.Left := 10;
FClearButton.Parent := Self;
FRefreshButton := TButton.Create(Self);
FRefreshButton.Caption := 'Refresh';
FRefreshButton.Align := alRight;
FRefreshButton.AlignWithMargins := True;
FRefreshButton.Margins.Left := 10;
FRefreshButton.Parent := Self;
FLabel1 := TLabel.Create(Self);
FLabel1.Caption := 'Foo caption: ';
FLabel1.Align := alLeft;
FLabel1.Layout := tlCenter;
FLabel1.Parent := Self;
FLabel2 := TLabel.Create(Self);
FLabel2.Caption := 'From 03/08/2012 to 06/06/2012';
FLabel2.Align := alLeft;
FLabel2.Layout := tlCenter;
FLabel2.Parent := Self;
end;
function TDateRangePicker.GetLabel1Caption: String;
begin
Result := FLabel1.Caption;
end;
function TDateRangePicker.GetRefreshButtonVisible: Boolean;
begin
Result := FRefreshButton.Visible;
end;
procedure TDateRangePicker.SetLabel1Caption(const Value: String);
begin
FLabel1.Caption := Value;
end;
procedure TDateRangePicker.SetRefreshButtonVisible(Value: Boolean);
begin
FRefreshButton.Visible := Value;
FRefreshButton.Left := Width;
end;
And the testing routine:
procedure TMainForm.TestButtonClick(Sender: TObject);
begin
DateRangePicker1.Label1Caption := 'Test: ';
DateRangePicker1.RefreshButtonVisible := not DateRangePicker1.RefreshButtonVisible;
end;
You can create a property for TDateRangePicker like :
property ShowRefresh:boolean read GetShowRefresh write SetShowRefresh
procedure TDateRangePicker.SetShowRefresh( Value : boolean);
begin
btnRefresh.Visible := Value;
// Force autosize after hidding Refresh button
Autosize := True;
end;
So, you have nothing to do during the drawing.
You set the intial positions when you create the child controls, and then update the positions at the time you need to update them (when changing the property, when the Parent component is resized, etc). You MUST NOT changing the positions inside the Paint() method or OnPaint event.
If you are using a modern version of Delphi, you should instead make use of the Align, Margins, and AlignWithMargins properties of the child controls. That way, you just position the controls one time at the time you create them, and let the VCL do all the hard work of repositioning them automatically when it needs to.
I have a check box control with a labeled edit as a published subcomponent.
What I'm trying to do is create a Translate procedure for the check box that would show the labeled edit on top, and allow the user to change the text of the check box's caption. Something like this:
constructor TPBxCheckBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTranslateEdit := TLabeledEdit.Create(Self);
FTranslateEdit.Parent := Self.Parent;
FTranslateEdit.SetSubComponent(True);
FTranslateEdit.Visible := False;
end;
procedure TPBxCheckBox.Translate(Show: Boolean);
begin
TranslateEdit.Left := Self.Left;
TranslateEdit.Top := Self.Top;
TranslateEdit.EditLabel.Caption := Self.Caption;
TranslateEdit.Text := Self.Caption;
TranslateEdit.Visible := Show;
TranslateEdit.Width := Self.Width;
end;
But this doesn't work - the labeled edit is never shown.
What am I doing wrong here?
It doesn't show because at TPBxCheckBox.Create() time Parent isn't yet assigned, so you're basically doing TranslateEdit.Parent := nil;.
If you really want your TranslatedEdit to have the same parent as the TPBxCheckBox itself, you could override SetParet and take action at the moment TPBxCheckBox's Parent is Assigned. Something like this:
TPBxCheckBox = class(TWhatever)
protected
procedure SetParent(AParent: TWinControl); override;
end;
procedure TPBxCheckBox.SetParent(AParent: TWinControl);
begin
inherited;
TranslatedEdit.Parent := AParent;
end;
When I make components with multiple parts I have not used the SetSubComponent method.
What I have done is something like this
constructor TPBxCheckBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FTranslateEdit := TLabeledEdit.Create(Self);
FTranslateEdit.Parent := Self;
FTranslateEdit.Visible := False;
end;
And I would try something like this
procedure TPBxCheckBox.Translate(Show: Boolean);
begin
FTranslateEdit.EditLabel.Caption := Self.Caption;
FTranslateEdit.Left := Self.Left;
FTranslateEdit.Top := Self.Top;
FTranslateEdit.Width := Self.Width;
FTranslateEdit.Height := Self.Height;
FTranslateEdit.Text := Self.Caption;
FTranslateEdit.Visible := Show;
end;
I'll improve this answer if you get me more information or if I get time to test this out.
How to dim / fade all other windows of an application in Delphi 2009.
Form has an AlphaBlend property, but it controls only transparency level. But it would be nice if we can have something like this
(Concentrated window) . Even stackoverflow.com does that, when we try to insert a link/ image etc in the post.
How can we achieve this in a delphi application?
Here is a unit I just knocked together for you.
To use this unit drop a TApplication component on your main form and in the OnModalBegin call _GrayForms and then in the OnModalEnd call the _NormalForms method.
This is a very simple example and could be made to be more complex very easily. Checking for multiple call levels etc....
For things like system (open, save, etc) dialogs you can wrap the dialog execute method in a try...finally block calling the appropriate functions to get a similar reaction.
This unit should work on Win2k, WinXP, Vista and should even work on Win7.
Ryan.
unit GrayOut;
interface
procedure _GrayForms;
procedure _GrayDesktop;
procedure _NormalForms;
implementation
uses windows, classes, forms, Contnrs, Types, Graphics, sysutils;
var
gGrayForms : TComponentList;
procedure _GrayDesktop;
var
loop : integer;
wScrnFrm : TForm;
wForm : TForm;
wPoint : TPoint;
begin
if not assigned(gGrayForms) then
begin
gGrayForms := TComponentList.Create;
gGrayForms.OwnsObjects := true;
for loop := 0 to Screen.MonitorCount - 1 do
begin
wForm := TForm.Create(nil);
gGrayForms.Add(wForm);
wForm.Position := poDesigned;
wForm.AlphaBlend := true;
wForm.AlphaBlendValue := 64;
wForm.Color := clBlack;
wForm.BorderStyle := bsNone;
wForm.Enabled := false;
wForm.BoundsRect := Screen.Monitors[loop].BoundsRect;
SetWindowPos(wForm.handle, HWND_TOP, 0,0,0,0, SWP_NOSIZE or SWP_NOMOVE);
wForm.Visible := true;
end;
end;
end;
procedure _GrayForms;
var
loop : integer;
wScrnFrm : TForm;
wForm : TForm;
wPoint : TPoint;
wScreens : TList;
begin
if not assigned(gGrayForms) then
begin
gGrayForms := TComponentList.Create;
gGrayForms.OwnsObjects := true;
wScreens := TList.create;
try
for loop := 0 to Screen.FormCount - 1 do
wScreens.Add(Screen.Forms[loop]);
for loop := 0 to wScreens.Count - 1 do
begin
wScrnFrm := wScreens[loop];
if wScrnFrm.Visible then
begin
wForm := TForm.Create(wScrnFrm);
gGrayForms.Add(wForm);
wForm.Position := poOwnerFormCenter;
wForm.AlphaBlend := true;
wForm.AlphaBlendValue := 64;
wForm.Color := clBlack;
wForm.BorderStyle := bsNone;
wForm.Enabled := false;
wForm.BoundsRect := wScrnFrm.BoundsRect;
SetWindowLong(wForm.Handle, GWL_HWNDPARENT, wScrnFrm.Handle);
SetWindowPos(wForm.handle, wScrnFrm.handle, 0,0,0,0, SWP_NOSIZE or SWP_NOMOVE);
wForm.Visible := true;
end;
end;
finally
wScreens.free;
end;
end;
end;
procedure _NormalForms;
begin
FreeAndNil(gGrayForms);
end;
initialization
gGrayForms := nil;
end.
I have done something similar for showing a modal form trying to keep the implementation as simple as possible. I don't know if this will fit your needs, but here it is:
function ShowModalDimmed(Form: TForm; Centered: Boolean = true): TModalResult;
var
Back: TForm;
begin
Back := TForm.Create(nil);
try
Back.Position := poDesigned;
Back.BorderStyle := bsNone;
Back.AlphaBlend := true;
Back.AlphaBlendValue := 192;
Back.Color := clBlack;
Back.SetBounds(0, 0, Screen.Width, Screen.Height);
Back.Show;
if Centered then begin
Form.Left := (Back.ClientWidth - Form.Width) div 2;
Form.Top := (Back.ClientHeight - Form.Height) div 2;
end;
result := Form.ShowModal;
finally
Back.Free;
end;
end;
I'm not sure about the "right" way to do it, but in order to "fade-to-white", what you can do is place your form in another completely white form (white background color, no controls).
So when your form is in 0% transparency, it will show as a regular form, but when it's in 50% transparency it will be faded to white. You can obviously choose other colors as your background.
I'm looking forward to seeing other answers...
EDIT: after seeing your "Jedi Concentrate" link, it seems that a dark-gray background will mimic the Expose effect better.
One way to do this is to place another form behind your dialog, this form would have no borders, and would contain a single image. This image would be a capture of the entire desktop from just before the dialog popped up, then run through a transform to lower the luminosity of each pixel by 50%. One trick that works quite well here is to use a black form, and to only include ever other pixel. If you know for certain that you will have theme support, you can optionally use a completely black form and use the alphablend and alphablendvalue properties..this will allow the OS to perform the luminosity transformation for you. An alphablendvalue of 128 is = 50%.
EDIT
As mghie pointed out, there is the possibility of a user pressing alt-tab to switch to another application. One way to handle this scenario would be to hide the "overlay" window in the application.OnDeactivate event, and to show it on the application.OnActivate event. Just remember to set the zorder of the overlay window lower than your modal dialog.
I created a similar effect to the Jedi Concentrate with a Form sized to the Screen.WorkArea with Color := clBlack and BorderStyle := bsNone
I found setting the AlphaBlendValue was too slow to animate nicely, so I use SetLayeredWindowAttributes()
The unit's code:
unit frmConcentrate;
{$WARN SYMBOL_PLATFORM OFF}
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs;
type
TFadeThread = class(TThread)
private
fForm: TForm;
public
constructor Create(frm: TForm);
procedure Execute; override;
end;
TConcentrateFrm = class(TForm)
procedure FormDestroy(Sender: TObject);
procedure FormClick(Sender: TObject);
private
{ Private declarations }
fThread: TFadeThread;
public
{ Public declarations }
end;
procedure StartConcentrate(aForm: TForm = nil);
var
ConcentrateFrm: TConcentrateFrm;
implementation
{$R *.dfm}
procedure StartConcentrate(aForm: TForm = nil);
var
Hnd: HWND;
begin
try
if not Assigned(ConcentrateFrm) then
ConcentrateFrm := TConcentrateFrm.Create(nil)
else
Exit;
ConcentrateFrm.Top := Screen.WorkAreaTop;
ConcentrateFrm.Left := Screen.WorkAreaLeft;
ConcentrateFrm.Width := Screen.WorkAreaWidth;
ConcentrateFrm.Height := Screen.WorkAreaHeight;
Hnd := GetForegroundWindow;
SetWindowLong(ConcentrateFrm.Handle, GWL_EXSTYLE,
GetWindowLong(ConcentrateFrm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED
);
SetLayeredWindowAttributes(
ConcentrateFrm.Handle,
ColorToRGB(clBlack),
0,
LWA_ALPHA
);
ConcentrateFrm.Show;
if Assigned(aForm) then
aForm.BringToFront
else
SetForegroundWindow(Hnd);
ConcentrateFrm.fThread := TFadeThread.Create(ConcentrateFrm);
Application.ProcessMessages;
ConcentrateFrm.fThread.Resume;
except
FreeAndNil(ConcentrateFrm);
end;
end;
procedure TConcentrateFrm.FormClick(Sender: TObject);
var
p: TPoint;
hnd: HWND;
begin
GetCursorPos(p);
ConcentrateFrm.Hide;
hnd := WindowFromPoint(p);
while GetParent(hnd) 0 do
hnd := GetParent(hnd);
SetForegroundWindow(hnd);
Release;
end;
procedure TConcentrateFrm.FormDestroy(Sender: TObject);
begin
ConcentrateFrm := nil;
end;
{ TFadeThread }
constructor TFadeThread.Create(frm: TForm);
begin
inherited Create(true);
FreeOnTerminate := true;
Priority := tpIdle;
fForm := frm;
end;
procedure TFadeThread.Execute;
var
i: Integer;
begin
try
// let the main form open before doing this intensive process.
Sleep(300);
i := 0;
while i < 180 do
begin
if not Win32Check(
SetLayeredWindowAttributes(
fForm.Handle,
ColorToRGB(clBlack),
i,
LWA_ALPHA
)
) then
begin
RaiseLastOSError;
end;
Sleep(10);
Inc(i, 4);
end;
except
end;
end;
end.