How to display dynamic text along with the mouse cursor - delphi

While a user is re-sizing a form, in XE2 I would like to display the current form size alongside the current mouse cursor. I would use the OnResize event.
In other words: I need ideas on how to display dynamic text (e.g. x,y coordinates like the 300, 250 in the image below) along with the mouse cursor as a user moves their mouse.
One approach would be to mock up a .cur file and assign it to the cursor in OnResize. That seems cumbersome and might be quite slow (and I have no idea yet of the file's contents)
Another idea would be to display some transparent text (what component would do that?) that I set .Top, .Left in the OnResize event.
One concern I have is how I would detect when the re-sizing operation is complete so I could revert to the standard mouse cursor.
Any suggestions a direction to proceed?

Update:
Here is an updated version, where was removed the hint animation part (since I feel you need to display the hint immediately for your purpose) and where was added double buffering (due to frequent updates of the hint) to prevent flickering and also a decent alpha blending (just for curiosity).
Thanks to #NGLN fixed a missing unassigning of a hint window variable!
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TAlphaHintWindow = class(THintWindow)
private
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWindowHandle(const Params: TCreateParams); override;
public
constructor Create(AOwner: TComponent); override;
procedure ActivateHint(Rect: TRect; const AHint: string); override;
end;
type
TForm1 = class(TForm)
private
FSizeMove: Boolean;
FHintWindow: TAlphaHintWindow;
procedure WMEnterSizeMove(var AMessage: TMessage); message WM_ENTERSIZEMOVE;
procedure WMSize(var AMessage: TWMSize); message WM_SIZE;
procedure WMExitSizeMove(var AMessage: TMessage); message WM_EXITSIZEMOVE;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TAlphaHintWindow }
constructor TAlphaHintWindow.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// window might be updated quite frequently, so enable double buffer
DoubleBuffered := True;
end;
procedure TAlphaHintWindow.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
// include the layered window style (for alpha blending)
Params.ExStyle := Params.ExStyle or WS_EX_LAYERED;
end;
procedure TAlphaHintWindow.CreateWindowHandle(const Params: TCreateParams);
begin
inherited CreateWindowHandle(Params);
// value of 220 here is the alpha (the same as form's AlphaBlendValue)
SetLayeredWindowAttributes(Handle, ColorToRGB(clNone), 220, LWA_ALPHA);
end;
procedure TAlphaHintWindow.ActivateHint(Rect: TRect; const AHint: string);
var
Monitor: TMonitor;
begin
// from here was just stripped the animation part and fixed one bug
// (setting a hint window top position when going off screen; it is
// at least in Delphi 2009 with the most recent updates)
Caption := AHint;
Inc(Rect.Bottom, 4);
UpdateBoundsRect(Rect);
Monitor := Screen.MonitorFromPoint(Point(Rect.Left, Rect.Top));
if Width > Monitor.Width then
Width := Monitor.Width;
if Height > Monitor.Height then
Height := Monitor.Height;
if Rect.Top + Height > Monitor.Top + Monitor.Height then
Rect.Top := (Monitor.Top + Monitor.Height) - Height;
if Rect.Left + Width > Monitor.Left + Monitor.Width then
Rect.Left := (Monitor.Left + Monitor.Width) - Width;
if Rect.Left < Monitor.Left then
Rect.Left := Monitor.Left;
if Rect.Top < Monitor.Top then
Rect.Top := Monitor.Top;
ParentWindow := Application.Handle;
SetWindowPos(Handle, HWND_TOPMOST, Rect.Left, Rect.Top, Width, Height,
SWP_NOACTIVATE);
ShowWindow(Handle, SW_SHOWNOACTIVATE);
Invalidate;
end;
procedure TAlphaHintWindow.CMTextChanged(var Message: TMessage);
begin
// do exactly nothing, because we're adjusting the size by ourselves
// and the ancestor would just autosize the window by the text; text
// or if you want Caption, is updated only by calling ActivateHint
end;
{ TForm1 }
procedure TForm1.WMEnterSizeMove(var AMessage: TMessage);
begin
inherited;
FSizeMove := True;
end;
procedure TForm1.WMSize(var AMessage: TWMSize);
var
CurPos: TPoint;
begin
inherited;
if FSizeMove and GetCursorPos(CurPos) then
begin
if not Assigned(FHintWindow) then
FHintWindow := TAlphaHintWindow.Create(nil);
FHintWindow.ActivateHint(
Rect(CurPos.X + 20, CurPos.Y - 20, CurPos.X + 120, CurPos.Y + 30),
'Current size' + sLineBreak +
'Width: ' + IntToStr(Width) + sLineBreak +
'Height: ' + IntToStr(Height));
end;
end;
procedure TForm1.WMExitSizeMove(var AMessage: TMessage);
begin
inherited;
FHintWindow.Free;
FHintWindow := nil;
FSizeMove := False;
end;
end.
And the result at form sizing (quite a lot transparent to my taste :-)

Does it really need to be transparent? Keep in mind that text can be hard to read over certain backgrounds.
Instead, consider showing a tool-tip window. Create a THintWindow control, set its caption and position, and show it.
When you receive a wm_ExitSizeMove message, hide or destroy the window.

Related

Custom control with non-client area - doesn't calculate at first

I'm writing a custom control which is simply a container with a non-client area. Within that non-client area, there's one small area which is a button, and the rest of it is transparent. The drawing isn't an exact rectangle.
So far, I have it half-way working. The problem is that it doesn't calculate the non-client area up front, unless I make a minor tweak, such as re-sizing it.
I've followed many resources describing how to accomplish this. My implementation of handling WM_NCCALCSIZE is more or less identical to "working" examples I've found. But when the control is first created, it does not calculate this at all. When I drop a breakpoint inside the message handler of mine (WMNCCalcSize), based on the examples I've found, I'm supposed to first check Msg.CalcValidRects, and only do my calculation if it's True. But when debugging run-time, it's False, thus the calculation isn't done.
In design-time, if I re-size the control, THEN it decides to calculate properly. It's still not perfect (this code is still in the works), but it doesn't seem to set the non-client area until after I tweak it. Further, in run-time, if I tweak the size in the code, it still doesn't calculate.
The image on the top is when the form is initially created/shown. The second one is after I re-size it a little bit. Notice the test button, which is aligned alLeft. So initially, it consumes the area which is supposed to be non-client.
If I comment out the check if Msg.CalcValidRects then begin, then it calculates properly. But I see every example doing this check, and I'm pretty sure it's needed.
What am I doing wrong and how to make it calculate the non-client area at all times?
unit FloatBar;
interface
uses
System.Classes, System.SysUtils, System.Types,
Vcl.Controls, Vcl.Graphics, Vcl.Forms,
Winapi.Windows, Winapi.Messages;
type
TFloatBar = class(TCustomControl)
private
FCollapsed: Boolean;
FBtnHeight: Integer;
FBtnWidth: Integer;
procedure RepaintBorder;
procedure PaintBorder;
procedure SetCollapsed(const Value: Boolean);
function BtnRect: TRect;
procedure SetBtnHeight(const Value: Integer);
procedure SetBtnWidth(const Value: Integer);
function TransRect: TRect;
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
procedure WMNCPaint(var Message: TWMNCPaint); message WM_NCPAINT;
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
procedure WMNCCalcSize(var Msg: TWMNCCalcSize); message WM_NCCALCSIZE;
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Repaint; override;
procedure Invalidate; override;
published
property BtnWidth: Integer read FBtnWidth write SetBtnWidth;
property BtnHeight: Integer read FBtnHeight write SetBtnHeight;
property Collapsed: Boolean read FCollapsed write SetCollapsed;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Float Bar', [TFloatBar]);
end;
{ TFloatBar }
constructor TFloatBar.Create(AOwner: TComponent);
begin
inherited;
ControlStyle:= [csAcceptsControls,
csCaptureMouse,
csDesignInteractive,
csClickEvents,
csReplicatable,
csNoStdEvents
];
Width:= 400;
Height:= 60;
FBtnWidth:= 50;
FBtnHeight:= 20;
FCollapsed:= False;
end;
procedure TFloatBar.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
destructor TFloatBar.Destroy;
begin
inherited;
end;
procedure TFloatBar.Invalidate;
begin
inherited;
RepaintBorder;
end;
procedure TFloatBar.Repaint;
begin
inherited Repaint;
RepaintBorder;
end;
procedure TFloatBar.RepaintBorder;
begin
if Visible and HandleAllocated then
Perform(WM_NCPAINT, 0, 0);
end;
procedure TFloatBar.SetBtnHeight(const Value: Integer);
begin
FBtnHeight := Value;
Invalidate;
end;
procedure TFloatBar.SetBtnWidth(const Value: Integer);
begin
FBtnWidth := Value;
Invalidate;
end;
procedure TFloatBar.SetCollapsed(const Value: Boolean);
begin
FCollapsed := Value;
Invalidate;
end;
procedure TFloatBar.WMNCPaint(var Message: TWMNCPaint);
begin
inherited;
PaintBorder;
end;
procedure TFloatBar.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
Message.Result := 1;
end;
procedure TFloatBar.WMNCCalcSize(var Msg: TWMNCCalcSize);
var
lpncsp: PNCCalcSizeParams;
begin
if Msg.CalcValidRects then begin //<------ HERE --------
lpncsp := Msg.CalcSize_Params;
if lpncsp = nil then Exit;
lpncsp.rgrc[0].Bottom:= lpncsp.rgrc[0].Bottom-FBtnHeight;
Msg.Result := 0;
end;
inherited;
end;
function TFloatBar.BtnRect: TRect;
begin
//Return a rect where the non-client collapse button is to be...
Result:= Rect(ClientWidth-FBtnWidth, ClientHeight, ClientWidth, ClientHeight+FBtnHeight);
end;
function TFloatBar.TransRect: TRect;
begin
//Return a rect where the non-client transparent area is to be...
Result:= Rect(0, ClientHeight, ClientWidth, ClientHeight+FBtnHeight);
end;
procedure TFloatBar.WMNCHitTest(var Message: TWMNCHitTest);
var
P: TPoint;
C: TCursor;
begin
C:= crDefault; //TODO: Find a way to change cursor elsewhere...
P:= Point(Message.XPos, Message.YPos);
if PtInRect(BtnRect, P) then begin
Message.Result:= HTCLIENT;
C:= crHandPoint;
end else
if PtInRect(TransRect, P) then
Message.Result:= HTTRANSPARENT
else
inherited;
Screen.Cursor:= C;
end;
procedure TFloatBar.Paint;
begin
inherited;
//Paint Background
Canvas.Brush.Style:= bsSolid;
Canvas.Pen.Style:= psClear;
Canvas.Brush.Color:= Color;
Canvas.FillRect(Canvas.ClipRect);
Canvas.Pen.Style:= psSolid;
Canvas.Pen.Width:= 3;
Canvas.Brush.Style:= bsClear;
Canvas.Pen.Color:= clBlue;
Canvas.MoveTo(0, 0);
Canvas.LineTo(ClientWidth, 0); //Top
Canvas.LineTo(ClientWidth, ClientHeight+FBtnHeight); //Right
Canvas.LineTo(ClientWidth-FBtnWidth, ClientHeight+FBtnHeight); //Bottom of Button
Canvas.LineTo(ClientWidth-FBtnWidth, ClientHeight); //Left of Button
Canvas.LineTo(0, ClientHeight); //Bottom
Canvas.LineTo(0, 0);
end;
procedure TFloatBar.PaintBorder;
begin
Canvas.Handle:= GetWindowDC(Handle);
try
//TODO: Paint "transparent" area by painting parent...
//Paint NC button background
Canvas.Brush.Style:= bsSolid;
Canvas.Pen.Style:= psClear;
Canvas.Brush.Color:= Color;
Canvas.Rectangle(ClientWidth-FBtnWidth, ClientHeight, ClientWidth, ClientHeight+FBtnHeight);
//Paint NC button border
Canvas.Pen.Style:= psSolid;
Canvas.Pen.Width:= 3;
Canvas.Brush.Style:= bsClear;
Canvas.Pen.Color:= clBlue;
Canvas.MoveTo(ClientWidth, ClientHeight);
Canvas.LineTo(ClientWidth, ClientHeight+FBtnHeight);
Canvas.LineTo(ClientWidth-FBtnWidth, ClientHeight+FBtnHeight);
Canvas.LineTo(ClientWidth-FBtnWidth, ClientHeight);
//Paint NC Button Chevron //TODO: Calculate chevron size/position
if FCollapsed then begin
Canvas.MoveTo(ClientWidth-30, ClientHeight+7);
Canvas.LineTo(ClientWidth-25, ClientHeight+13);
Canvas.LineTo(ClientWidth-20, ClientHeight+7);
end else begin
Canvas.MoveTo(ClientWidth-30, ClientHeight+13);
Canvas.LineTo(ClientWidth-25, ClientHeight+7);
Canvas.LineTo(ClientWidth-20, ClientHeight+13);
end;
finally
ReleaseDC(Handle, Canvas.Handle);
end;
end;
end.
... I'm supposed to first check Msg.CalcValidRects, and only do my
calculation if it's True.
You've got that wrong. The message has a somewhat complicated mechanism and the documentation might be slightly confusing trying to explain two distinct mode the message operates (wParam true or false). The part that relates to your case is the second paragraph of lParam:
If wParam is FALSE, lParam points to a RECT structure. On entry, the
structure contains the proposed window rectangle for the window. On
exit, the structure should contain the screen coordinates of the
corresponding window client area.
You'll find numerous usage examples of this simple form in the VCL where wParam is not checked at all, like in TToolWindow.WMNCCalcSize, TCustomCategoryPanel.WMNCCalcSize etc..
(Note that NCCALCSIZE_PARAMS.rgrc is not even a rectangle array when wParam is false, but since you're operating on the supposed first rectangle, you're fine.)

Overlapping TCustomControl objects draw out of order when the form is created/restored

I'm having issues getting a TCustomControl to work with transparency in Delphi 2007. I've currently reduced the problem to the code below. The issue is that when the form is initially created the controls are drawing in the reverse order they are added to the form. When the form is resized, they paint in the correct order. What am I doing wrong? Excluding 3rd party solutions is there a more appropriate path to follow?
Here's my sample project demonstrating the issue in Delphi 2007.
unit Main;
interface
uses
Forms, Classes, Controls, StdCtrls, Messages,
ExtCtrls;
type
// Example of a TWinControl derived control
TMyCustomControl = class(TCustomControl)
protected
procedure CreateParams(var params: TCreateParams); override;
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd);
message WM_ERASEBKGND;
procedure Paint; override;
end;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
YellowBox: TMyCustomControl;
GreenBox: TMyCustomControl;
end;
var
Form1: TForm1;
implementation
uses
Windows, Graphics;
{$R *.dfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
self.OnPaint := FormPaint;
GreenBox := TMyCustomControl.Create(self);
GreenBox.Parent := self;
GreenBox.SetBounds(10,10,200,200);
GreenBox.color := clGreen;
YellowBox := TMyCustomControl.Create(self);
YellowBox.Parent := self;
YellowBox.SetBounds(100,100,200,200);
YellowBox.color := clYellow;
end;
// Paint bars on form background
procedure TForm1.FormPaint(Sender: TObject);
var
Idx: Integer;
begin
for Idx := 0 to ClientHeight div 8 do
begin
if Odd(Idx) then
Canvas.Brush.Color := clWhite
else
Canvas.Brush.Color := clSilver; // pale yellow
Canvas.FillRect(Rect(0, Idx * 8, ClientWidth, Idx * 8 + 8));
end;
end;
{ TMyCustomControl }
procedure TMyCustomControl.CreateParams(var params: TCreateParams);
begin
inherited;
params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT;
end;
procedure TMyCustomControl.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
SetBkMode (msg.DC, TRANSPARENT);
msg.result := 1;
end;
procedure TMyCustomControl.Paint;
begin
Canvas.Brush.Color := color;
Canvas.RoundRect(0,0,width,height,50,50);
end;
end.
What is wrong is your expectancy of the order of painting of your controls. The order of controls receiving WM_PAINT messages is documented to be actually in the exact opposite order, the top-most control receives the message first. More on the documentation later, since having WS_EX_TRANSPARENT styled siblings leaves us in undocumented territory. As you have already noted, you have a case where the order of the controls receiving WM_PAINT messages is not deterministic - when resizing the window the order changes.
I've modified a bit of your reproduction case to see what is happening. The modifications are the inclusion of two panels and a debug output when they receive WM_PAINT.
unit Unit1;
interface
uses
Forms, Classes, Controls, StdCtrls, Messages, ExtCtrls;
type
TMyCustomControl = class(TCustomControl)
protected
procedure CreateParams(var params: TCreateParams); override;
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd);
message WM_ERASEBKGND;
procedure Paint; override;
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
end;
TPanel = class(extctrls.TPanel)
protected
procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
end;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
YellowBox: TMyCustomControl;
GreenBox: TMyCustomControl;
Panel1, Panel2: TPanel;
end;
var
Form1: TForm1;
implementation
uses
sysutils, windows, graphics;
{$R *.dfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
Width := 590;
Height := 270;
OnPaint := FormPaint;
GreenBox := TMyCustomControl.Create(self);
GreenBox.Parent := self;
GreenBox.SetBounds(20, 20, 140, 140);
GreenBox.color := clGreen;
GreenBox.Name := 'GreenBox';
//{
Panel1 := TPanel.Create(Self);
Panel1.Parent := Self;
Panel1.SetBounds(240, 40, 140, 140);
Panel1.ParentBackground := False;
Panel1.Color := clMoneyGreen;
Panel1.Name := 'Panel1';
Panel2 := TPanel.Create(Self);
Panel2.Parent := Self;
Panel2.SetBounds(260, 60, 140, 140);
Panel2.ParentBackground := False;
Panel2.Color := clCream;
Panel2.Name := 'Panel2';
//}
YellowBox := TMyCustomControl.Create(self);
YellowBox.Parent := self;
YellowBox.SetBounds(80, 80, 140, 140);
YellowBox.color := clYellow;
YellowBox.Name := 'YellowBox';
YellowBox.BringToFront;
end;
// Paint bars on form background
procedure TForm1.FormPaint(Sender: TObject);
var
Idx: Integer;
begin
for Idx := 0 to ClientHeight div 8 do
begin
if Odd(Idx) then
Canvas.Brush.Color := clWhite
else
Canvas.Brush.Color := clSilver; // pale yellow
Canvas.FillRect(Rect(0, Idx * 8, ClientWidth, Idx * 8 + 8));
end;
end;
{ TPanel }
procedure TPanel.WMPaint(var Message: TWMPaint);
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
inherited;
end;
{ TMyCustomControl }
procedure TMyCustomControl.CreateParams(var params: TCreateParams);
begin
inherited;
params.ExStyle := params.ExStyle or WS_EX_TRANSPARENT;
end;
procedure TMyCustomControl.WMEraseBkGnd(var msg: TWMEraseBkGnd);
begin
msg.Result := 1;
end;
procedure TMyCustomControl.WMPaint(var Message: TWMPaint);
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
inherited;
end;
procedure TMyCustomControl.Paint;
begin
Canvas.Brush.Color := Color;
Canvas.RoundRect(0, 0, Width, Height, 50, 50);
end;
end.
Which produces this form:
As determined by order of creation, the z-order is, from bottom to top,
GreenBox,
Panel1,
Panel2,
YellowBox.
The debug output for the WM_PAINT messages is this:
Debug Output: Panel2 painting.. Process Project1.exe (12548)
Debug Output: Panel1 painting.. Process Project1.exe (12548)
Debug Output: YellowBox painting.. Process Project1.exe (12548)
Debug Output: GreenBox painting.. Process Project1.exe (12548)
There are two things worth to note in this order.
First, Panel2 receives the paint message before Panel1, although Panel2 is higher in the z-order.
So how is it that while we see Panel2 as a whole, but we see only part of Panel1 even though it is painted later? This is where update regions come into play. The WS_CLIPSIBLINGS style flags in controls tell the OS that part of a control occupied by a sibling higher in the z-order is not going to be painted.
Clips child windows relative to each other; that is, when a particular
child window receives a WM_PAINT message, the WS_CLIPSIBLINGS
style clips all other overlapping child windows out of the region of
the child window to be updated.
Let's dig into a bit more in the WM_PAINT handler of Panel1 and see how the OS' update region looks like.
{ TPanel }
// not declared in D2007
function GetRandomRgn(hdc: HDC; hrgn: HRGN; iNum: Integer): Integer; stdcall;
external gdi32;
const
SYSRGN = 4;
procedure TPanel.WMPaint(var Message: TWMPaint);
var
PS: TPaintStruct;
Rgn: HRGN;
TestDC: HDC;
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
Message.DC := BeginPaint(Handle, PS);
Rgn := CreateRectRgn(0, 0, 0, 0);
if (Name = 'Panel1') and (GetRandomRgn(Message.DC, Rgn, SYSRGN) = 1) then begin
OffsetRgn(Rgn, - Form1.ClientOrigin.X + Width + 40, - Form1.ClientOrigin.Y);
TestDC := GetDC(Form1.Handle);
SelectObject(TestDC, GetStockObject(BLACK_BRUSH));
PaintRgn(TestDC, Rgn);
ReleaseDC(Form1.Handle, TestDC);
DeleteObject(Rgn);
end;
inherited;
EndPaint(Handle, PS);
end;
The BeginPaint will clip the update region with the system update region which you can then retrieve with GetRandomRgn. I've dumped the clipped update region to the right of the form. Don't mind the Form1 references or missing error checks, we are only debugging. Anyway, this produces the below form:
So, whatever you draw in the client area of Panel1, it will get clipped into the black shape, hence it cannot be visually come into front of Panel2.
Second, remember that the green box is created first, then the panels and then the yellow last. So why is it that the two transparent controls are painted after the two panels?
First, remember that controls are painted from top to bottom. Now, how can it be possible for a transparent control to draw onto something which is drawn after it? Obviously it is not possible. So the entire painting algorithm have to change. There is no documentation on this and the best explanation I've found is from a blog entry of Raymond Chen:
... The WS_EX_TRANSPARENT extended window style alters the painting
algorithm as follows: If a WS_EX_TRANSPARENT window needs to be
painted, and it has any non-WS_EX_TRANSPARENT windows siblings (which
belong to the same process) which also need to be painted, then the
window manager will paint the non-WS_EX_TRANSPARENT windows first.
The top to bottom painting order makes it a difficult one when you have transparent controls. Then there is the case of overlapping transparent controls - which is more transparent than the other? Just accept the fact that overlapping transparent controls produce undetermined behavior.
If you investigate the system update regions of the transparent boxes in the above test case, you'll find both to be exact squares.
Let's shift the panels to in-between the boxes.
procedure TForm1.FormCreate(Sender: TObject);
begin
Width := 590;
Height := 270;
OnPaint := FormPaint;
GreenBox := TMyCustomControl.Create(self);
GreenBox.Parent := self;
GreenBox.SetBounds(20, 20, 140, 140);
GreenBox.color := clGreen;
GreenBox.Name := 'GreenBox';
//{
Panel1 := TPanel.Create(Self);
Panel1.Parent := Self;
Panel1.SetBounds(40, 40, 140, 140);
Panel1.ParentBackground := False;
Panel1.Color := clMoneyGreen;
Panel1.Name := 'Panel1';
Panel2 := TPanel.Create(Self);
Panel2.Parent := Self;
Panel2.SetBounds(60, 60, 140, 140);
Panel2.ParentBackground := False;
Panel2.Color := clCream;
Panel2.Name := 'Panel2';
//}
YellowBox := TMyCustomControl.Create(self);
YellowBox.Parent := self;
YellowBox.SetBounds(80, 80, 140, 140);
YellowBox.color := clYellow;
YellowBox.Name := 'YellowBox';
YellowBox.BringToFront;
end;
...
procedure TMyCustomControl.WMPaint(var Message: TWMPaint);
var
PS: TPaintStruct;
Rgn: HRGN;
TestDC: HDC;
begin
OutputDebugString(PChar(Format(' %s painting..', [Name])));
Message.DC := BeginPaint(Handle, PS);
Rgn := CreateRectRgn(0, 0, 0, 0);
if (Name = 'GreenBox') and (GetRandomRgn(Message.DC, Rgn, SYSRGN) = 1) then begin
OffsetRgn(Rgn, - Form1.ClientOrigin.X + Width + 260, - Form1.ClientOrigin.Y);
TestDC := GetDC(Form1.Handle);
SelectObject(TestDC, GetStockObject(BLACK_BRUSH));
PaintRgn(TestDC, Rgn);
ReleaseDC(Form1.Handle, TestDC);
DeleteObject(Rgn);
end;
inherited;
EndPaint(Handle, PS);
end;
The right-most black shape is the system update region for the GreenBox. After all the system can apply clipping to a transparent control. I think it would suffice to conclude that the painting algorithm is not perfect when you've got a bunch of transparent controls.
As promised, the documentation quote for the WM_PAINT order. One reason I've left this to last is that it includes a possible solution (of course we already found one solution, scatter some non-transparent controls in-between your transparent controls):
... If a window in the parent chain is composited (a window with
WX_EX_COMPOSITED), sibling windows receive WM_PAINT messages in the
reverse order of their position in the Z order. Given this, the window
highest in the Z order (on the top) receives its WM_PAINT message
last, and vice versa. If a window in the parent chain is not
composited, sibling windows receive WM_PAINT messages in Z order.
For as little as I tested, setting WS_EX_COMPOSITED on the parent form seems to work. But I don't know if it is applicable in your case.

How to display TBalloonHint always downwards independently from the screen position?

Create a VCL Forms Application, put a TBalloonHint (Name: balloonhintTest) and a TButton (Name: btnTest) on the form and write this code:
procedure TForm2.FormCreate(Sender: TObject);
begin
balloonhintTest.HideHint;
balloonhintTest.Style := bhsStandard;
end;
procedure TForm2.btnTestMouseEnter(Sender: TObject);
begin
if not balloonhintTest.ShowingHint then
begin
balloonhintTest.Title := 'My Title';
balloonhintTest.Description := 'MyDescription';
balloonhintTest.ShowHint(Self.ClientToScreen(Point(btnTest.Left + (btnTest.Width div 2), btnTest.Top + btnTest.Height)));
end;
end;
procedure TForm2.btnTestMouseLeave(Sender: TObject);
begin
balloonhintTest.HideHint;
end;
Now run the program and hover your mouse pointer over the button.
This is how it looks when the window is on the UPPER PART OF THE SCREEN:
And this is how it looks when the window is on the LOWER PART OF THE SCREEN:
As you can see - although the Hint coordinates are always the same - the hint is displayed DOWNWARDS in the first case (desired result) and UPWARDS in the second case (obviously not the desired result), depending on the vertical position of the window on the screen.
So how can I display the balloon hint in this case always DOWNWARDS independently from the screen position?
(Please note: I am not interested in the other overloadings of the ShowHint method - I just want to know how to display the hint always downwards in the above case, as this is only the simplified scenario of a more complex case).
Probably easiest way is to create your own class based on TBalloonHint as
type
TMyHint = class(TBalloonHint)
strict private
FControl: TControl;
public
procedure PaintHint(HintWindow: TCustomHintWindow); override;
constructor Create(AOwner: TComponent; const AControl: TControl);
end;
constructor TMyHint.Create(AOwner: TComponent; const AControl: TControl);
begin
inherited Create(AOwner);
FControl := AControl;
end;
procedure TMyHint.PaintHint(HintWindow: TCustomHintWindow);
var
Point: TPoint;
begin
Point := FControl.Parent.ClientToScreen(TPoint.Create(FControl.Left, FControl.Top + FControl.Height));
HintWindow.Top := Point.Y;
inherited;
end;
create it as
procedure TMainForm.FormCreate(Sender: TObject);
begin
balloonHintTest := TMyHint.Create(Self, btnTest);
balloonHintTest.Style := bhsStandard;
end;
I think it is even easier if you just apply a check on whether the showing point is on the lower part of the form to which the balloonhint belongs, and if yes add, sth like that. The height of the balloonHint can be calculated via textHeight
procedure TForm2.FormCreate(Sender: TObject);
begin
balloonhintTest.HideHint;
balloonhintTest.Style := bhsStandard;
end;
procedure TForm2.btnTestMouseEnter(Sender: TObject);
begin
if not balloonhintTest.ShowingHint then
begin
balloonhintTest.Title := 'My Title';
balloonhintTest.Description := 'MyDescription';
TPoint pointCheck = Self.ClientToScreen(Point(btnTest.Left + (btnTest.Width div 2), btnTest.Top + btnTest.Height));
if(pointCheck.y>0.5*Self.Height)
int yShift = balloonhintTest.Height;
pointCheck.y = pointCheck.y - yShift;
end if
balloonhintTest.ShowHint(pointCheck);
end;
end;
procedure TForm2.btnTestMouseLeave(Sender: TObject);
begin
balloonhintTest.HideHint;
end;

Highlight TPanel on mouse move

I'm trying to make app to show some information, It'll create Panels runtime and place info on it, each panel will be flat as on picture, also app will use runtime themes, so i'd not be able to change panel bg color on mouse move, I tried to place info on TSpeedButton :v O.o it has wonderfull highlight function when it's flat while app is using runtime theme, but the main problem is that images and labels aren't moving when i move speedbutton and i need this much, they just stay there..
I tried to edit TCustomPanel.Paint to see if panel will look like highlighted button, adding code at the end:
PaintRect := ClientRect;
Details := StyleServices.GetElementDetails(ttbButtonHot);
StyleServices.DrawElement(Canvas.Handle, Details, PaintRect);
but with no success..
also it's pretty hard to link some custom code OnClick event at runtime, e.g:
ShowMessage('custom message on each panel');
I have not got any idea on how to do this, hope some one will give me advice or show me some example..
btw, panel will be created this way:
var
P: TPanel;
begin
P := TPanel.Create(Self);
P.Left := 20;
P.Top := 100;
P.Width := 60;
P.Height := 20;
P.Visible := True;
P.Parent := Self;
#P.OnClick := #Showmessageproc; // somehow this way..
end;
App pic:
If i do so:
procedure TMyPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
var
mEvnt: TTrackMouseEvent;
begin
inherited;
if not FMouseTracking then begin
mEvnt.cbSize := SizeOf(mEvnt);
mEvnt.dwFlags := TME_LEAVE;
mEvnt.hwndTrack := Handle;
TrackMouseEvent(mEvnt);
FMouseTracking := True;
showmessage('IN');
end;
end;
procedure TMyPanel.WMMouseLeave(var Msg: TMessage);
begin
if Msg.Msg = WM_MOUSELEAVE then showmessage('OUT');
Msg.Result := 0;
FMouseTracking := False;
if Assigned(FOnMouseLeave) then
FOnMouseLeave(Self);
end;
procedure G(Sender: TObject);
begin
showmessage('message');
end;
procedure TMainFrm.Button1Click(Sender: TObject);
var
P: TMyPanel;
begin
P := TMyPanel.Create(Self);
P.Left := 20;
I := I + 100;
P.Top := I;
P.Width := 200;
P.Height := 80;
P.Visible := True;
P.Parent := Self;
#P.OnClick := #g;
end;
when I move mouse on runtime created panel, 2 msgbox appears, IN and OUT, "mousemove" works fine but "mouse leave" bad, also the mainc question is still actual. the problem is that that I can't get canvas of created panel to draw on. the example above could be achieved more simple way:
#P.OnMouseLeave := #onmouseleaveproc;
#P.OnMouseMove := #onmousemoveproc;
but with Canvas, everything is more difficult, somewhere i've read that canvas is protected in TCustomPanel.
Also there's another question: Is it possible to handle panel wich called e.g OnMouseMove ? because there maybe will be 30 of them (runtime created panels)
I've tried this way: (and it does not works)
type
TMyPanel = class(TPanel)
public
constructor Create(AOwner: TComponent); override;
private
// FMouseTracking: Boolean;
// FOnMouseLeave: TNotifyEvent;
procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
protected
// procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
published
// property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
end;
constructor TMyPanel.Create(AOwner: TComponent);
begin
ControlStyle := ControlStyle - [csParentBackground] + [csOpaque];
inherited;
end;
procedure TMyPanel.CMMouseEnter(var msg: TMessage);
begin
inherited;
Color := clBlue;
{ Do Whatever }
end;
procedure TMyPanel.CMMouseLeave(var msg: TMessage);
begin
inherited;
Color := clRed;
{ Do Whatever }
end;
Simply, color does not changes. (color changes with themes OFF)
It's basically explained here for Delphi 6, but same concept I think. You want to define a custom windows message handler for your panel. This will give you basic mouse enter/exit capability. You can then play with setting TPanel properties from there to find something to your liking. For example, to mock a speed button, you might be able to just set the background color and change the border bevel accordingly. If that isn't adequate, you can write to the TPanel's Canvas directly (paint the behavior that you want to see) on mouse enter/exit to get the visual behavior you're after.
I created the following new component in Delphi and installed it. A new TColorPanel component showed up in a new MyComponents tab in the IDE. I then used this to put a TColorPanel on a new app and it responded properly to the mouse enter/leave events, changing the color as desired. I'm not sure how you made your app's panels as TMyPanel instead of standard TPanel. This is just how I tried it. I used your latest message handling code as-is.
unit ColorPanel;
interface
uses
WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
TColorPanel = class(TPanel)
public
constructor Create(AOwner: TComponent); override;
private
procedure CMMouseEnter(var msg: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var msg: TMessage); message CM_MOUSELEAVE;
protected
// procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
published
// property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('MyComponents', [TColorPanel]);
end;
constructor TColorPanel.Create(AOwner: TComponent);
begin
ControlStyle := ControlStyle - [csParentBackground] + [csOpaque];
inherited;
end;
procedure TColorPanel.CMMouseEnter(var msg: TMessage);
begin
inherited;
Color := clBlue;
{ Do Whatever }
end;
procedure TColorPanel.CMMouseLeave(var msg: TMessage);
begin
inherited;
Color := clRed;
{ Do Whatever }
end;
end.
I'm not sure why yours isn't working, other than to determine how you declared your app's panels to be TMyPanel.

how to set background image to TListview in Delphi XE?

how i can to to set background image to TListview in Delphi XE??
i want to make a application like Windows Explorer.
In order to set a watermark in the listview you need to use the LVM_SETBKIMAGE message, and you need to override the TListView's default WM_ERASEBKGND message. The listview takes ownership of the bitmap handle, so you need to use TBitmap's ReleaseHandle, rather than just Handle.
If you want it aligned to the top-left, instead of the bottom right like Explorer, use LVBKIF_SOURCE_HBITMAP instead of LVBKIF_TYPE_WATERMARK for the ulFlags value.
uses
CommCtrl, ...;
type
TListView = class(ComCtrls.TListView)
protected
procedure WndProc(var Message: TMessage);
override;
end;
TForm4 = class(TForm)
ListView1: TListView;
procedure FormCreate(Sender: TObject);
end;
procedure TListView.WndProc(var Message: TMessage);
begin
if Message.Msg = WM_ERASEBKGND then
DefaultHandler(Message)
else
inherited WndProc(Message);
end;
procedure TForm4.FormCreate(Sender: TObject);
var
Img: TImage;
BkImg: TLVBKImage;
begin
FillChar(BkImg, SizeOf(BkImg), 0);
BkImg.ulFlags := LVBKIF_TYPE_WATERMARK;
// Load image and take ownership of the bitmap handle
Img := TImage.Create(nil);
try
Img.Picture.LoadFromFile('C:\Watermark.bmp');
BkImg.hbm := Img.Picture.Bitmap.ReleaseHandle;
finally
Img.Free;
end;
// Set the watermark
SendMessage(ListView1.Handle, LVM_SETBKIMAGE, 0, LPARAM(#BkImg));
end;
Stretched Watermark
The listview doesn't natively support stretching a bitmap across the entire background. To do so you need to do a StretchBlt in response to WM_ERASEBKGND yourself.
type
TMyListView = class(TListView)
protected
procedure CreateHandle; override;
procedure CreateParams(var Params: TCreateParams); override;
procedure WMEraseBkgnd(var Msg: TWMEraseBkgnd); message WM_ERASEBKGND;
public
Watermark: TBitmap;
end;
procedure TMyListView.CreateHandle;
begin
inherited;
// Set text background color to transparent
SendMessage(Handle, LVM_SETTEXTBKCOLOR, 0, CLR_NONE);
end;
procedure TMyListView.CreateParams(var Params: TCreateParams);
begin
inherited;
// Invalidate every time the listview is resized
Params.Style := Params.Style or CS_HREDRAW or CS_VREDRAW;
end;
procedure TMyListView.WMEraseBkgnd(var Msg: TWMEraseBkgnd);
begin
StretchBlt(Msg.DC, 0, 0, Width, Height, Watermark.Canvas.Handle,
0, 0, Watermark.Width, Watermark.Height, SrcCopy);
Msg.Result := 1;
end;
a Tlistview is nice but if you want more. i suggess you have to update with VirtualStringTree(VirtualTreeView) very flexible you can customize it almost anything you want and most of all its free.

Resources