Using the following code in Delphi 2007:
procedure TfrmTest.PaintBox1Paint(Sender: TObject);
const
Rect_Size = 10;
begin
PaintBox1.Canvas.Brush.Color := clYellow;
PaintBox1.Canvas.FillRect(Rect(0, 0, PaintBox1.width, PaintBox1.height));
PaintBox1.Canvas.Brush.Color := clRed;
DrawARect(PaintBox1.Canvas, 0, 0, Rect_Size, Rect_Size);
end;
procedure TfrmTest.DrawARect(ACanvas: TCanvas; iLeft, iTop, iWidth, iHeight: Integer);
var
rgnMain: HRGN;
begin
rgnMain := CreateRectRgn(iLeft, iTop, iLeft + iWidth, iTop + iHeight);
try
SelectClipRgn(ACanvas.handle, rgnMain);
ACanvas.FillRect(ACanvas.ClipRect);
SelectClipRgn(ACanvas.handle, 0);
finally
DeleteObject(rgnMain);
end;
end;
I get this:
(Yellow area shows boundaries of PaintBox1).
alt text http://www.freeimagehosting.net/uploads/62cf687d29.jpg
(Image shows a form with a yellow box [PaintBox1] in the center. However my red rectange [rgnMain] has been drawn at pos 0,0 on the form)
My expectation was that the red rectangle would be at the top left of the PaintBox1 canvas, not the form's canvas. Why is it not? Can regions only be used with controls that have a Windows handle?
Thanks
Device Contexts require a window handle. What VCL does for non-windowed controls is to offset the view port of the DC acquired for the TWinControl they are on, by using SetWindowOrgEx in TWinControl.PaintControls. The new view port is in logical units. So for 'TGraphicControl's, which does not descend from TWinControl, you can use GDI functions which work on logical coordinates. See the remarks section for SelectClipRgn, which says the coordinates should be specified in device units. You'd offset the region or the coordinates.
Related
In firemonkey I am trying to make a progressbar using rectangles with round corners. The simplest case is a rectangle (the progressbar) and the second rectangle inside it (progress till now). Attached a simple example is provided.
Progressbar with corners (paint):
I've tried the following things:
Let the second rectangle also have rounded corners. This doesn't work because these roundings will change if the second rectangle is very short or almost at the end.
Use clipchildren. This is almost the same as hiding overflow in html / css, but Delphi does not include rounded corners in this function.
Create a TPath in which the image should be drawn. I really like to avoid this solution, because it doesn't use the stylebook. I prefer using one stylebook for all styles, instead of using multiple places in the code for style solutions.
What does work:
There is one really ugly method to make this work. I use that method now, but I really hope you can help me find another solution. The ugly method is:
Just use one rectangle. Fill it with a gradient brush, set the two gradient point at the same place and make the gradient itself 0 degrees. The result of this method is a lot of ugly code when I've to change the status of the progressbar etc.
Is this something we can avoid, or is this the only solution that is possible?
Progressbar goal (paint):
Thank you in advance!
Jan
I'm not sure what you mean by
Use clipchildren. This is almost the same as hiding overflow in html / css, but Delphi does not include rounded corners in this function.
I got this to work by using one Rectangle for the border; on top of that a Layout for the progress, which contains another Rectangle. The second Rectangle always has the dimensions of the first (which means the corners look the same), the Layout's ClipChildren is set to true, and the progress is controlled by setting its Width.
Here's how I implemented it:
type
TRoundProgressBar = class (TLayout)
strict private
FProgress: Single;
FFill: TBrush;
FStroke: TStrokeBrush;
StrokeRect, FillRect: TRectangle;
FillLayout: TLayout;
procedure SetFill(const Value: TBrush);
procedure SetStroke(const Value: TStrokeBrush);
procedure FillChanged(Sender: TObject);
procedure StrokeChanged(Sender: TObject);
procedure SetProgress(Progress: Single);
procedure UpdateWidths;
protected
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Fill: TBrush read FFill write SetFill;
property Stroke: TStrokeBrush read FStroke write SetStroke;
property Progress: Single read FProgress write SetProgress;
end;
implementation
constructor TRoundProgressBar.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFill := TBrush.Create(TBrushKind.Solid, $FFE0E0E0);
FFill.OnChanged := FillChanged;
FStroke := TStrokeBrush.Create(TBrushKind.Solid, $FF000000);
FStroke.OnChanged := StrokeChanged;
FillLayout := TLayout.Create(self);
FillLayout.Parent := self;
FillLayout.Align := TAlignLayout.Left;
FillLayout.ClipChildren := true;
FillRect := TRectangle.Create(FillLayout);
FillRect.Parent := FillLayout;
FillRect.Align := TAlignLayout.Left;
FillRect.XRadius := 15;
FillRect.YRadius := 15;
StrokeRect := TRectangle.Create(self);
StrokeRect.Parent := self;
StrokeRect.Align := TAlignLayout.Contents;
StrokeRect.XRadius := 15;
StrokeRect.YRadius := 15;
StrokeRect.Fill.Kind := TBrushKind.None;
end;
destructor TRoundProgressBar.Destroy;
begin
FFill.Free;
FStroke.Free;
inherited;
end;
procedure TRoundProgressBar.SetFill(const Value: TBrush);
begin
FFill.Assign(Value);
end;
procedure TRoundProgressBar.SetProgress(Progress: Single);
begin
FProgress := Min(Max(Progress, 0), 100);
UpdateWidths;
end;
procedure TRoundProgressBar.FillChanged(Sender: TObject);
begin
FillRect.Fill.Assign(FFill);
end;
procedure TRoundProgressBar.Resize;
begin
inherited;
UpdateWidths;
end;
procedure TRoundProgressBar.SetStroke(const Value: TStrokeBrush);
begin
FStroke.Assign(Value);
end;
procedure TRoundProgressBar.StrokeChanged(Sender: TObject);
begin
StrokeRect.Stroke.Assign(FStroke);
end;
procedure TRoundProgressBar.UpdateWidths;
begin
FillRect.Width := Width;
FillLayout.Width := Width * (FProgress / 100);
Repaint;
end;
Exactly clipchildren can not work, because it's use the bounding box of the control (so a Rectf). however what you can do :
1) override the onpaint of the trectangle (it's quite simple)
2) Use 2 Trectangles (call them orange and white), on the first tRectangle (orange) you set to not draw the left sides (via the Sides property of Trectangle) and of the second Trectangle (white) you set to not draw the right sides (also via the sides property). put these 2 Trectangles inside a Tlayout (or any other container you would like), set the align of the second Trectangle (white) to all, and the align of the first Trectangle (orange) to ALleft. after you just need to say MyOrangeRect.width := XX where xx the amount of your progress relative to the with of the container off course
I like to chip in with another solution with just one TRectangle:
Just add a TRectangle, set your borders, corners and set the fill property to TBitmap.
Now you can create a TBitmap with a color (with the width as progress) to the fill.bitmap.bitmap (notice the double bitmap) property at runtime.
Your corners are still respected.
extra: You can also use a one vertical line bitmap created in photoshop with a nice glow/color effect like the IOS battery progress bar and stretch that in your TRectangle.
Just use two shapes (roundrect) like this:
procedure TForm4.SpinBox1Change(Sender: TObject);
begin
roundrect2.Width:=strtoint(SpinBox1.Text);
end;
And change the width property of the upper shape when ever you want to progress more;
When a TRectangle is painted internally it actually creates a path.
The best solution for you would be to make a custom component, which contains two TPathData (call them e.g. PathBackground and PathFill), that are recalculated when the percentage changes and when it is resized.
In the Paint routine I would paint this way
Canvas.FillPath(PathBackground, ...);
Canvas.FillPath(PathFill, ...);
Canvas.DrawPath(PathBackground, ...);
By drawing the edge as the last thing, you avoid rendering errors.
So what i'm doing is display the x and y values of the mouse pointer on a teechart chart using the following code, inside the onmousemove event:
oscilografia.Repaint;
if ((x>236) and (x<927)) and ((y>42) and (y<424)) then
begin
oscilografia.Canvas.Brush.Style := bsSolid;
oscilografia.Canvas.Pen.Color := clBlack;
oscilografia.Canvas.Brush.Color := clWhite;
oscilografia.Canvas.TextOut(x+10,y,datetimetostr(oscilografia.Series[0].XScreenToValue(x))+','+FormatFloat('#0.00',oscilografia.series[0].YScreenToValue(y)));
edit1.Text:=inttostr(x)+' '+inttostr(y);
end;
The code works fine, but a problem happens when i make another series visible by selecting it on the legend: the text inside the box created by canvas.textout isn´t shown anymore.
The box is still there following the mouse, but without any text. So i would like a solution to this.
The basic problem is down to how painting works. Windows do not have persistent drawing surfaces. What you paint onto a window will be overwritten the next time the system needs to repaint it.
You need to arrange that all painting is in response to WM_PAINT messages. In Delphi terms that typically means that you would put your painting code in an overridden Paint method.
So the basic process goes like this:
Derive a sub-class of the chart control and in that class override Paint. Call the inherited Paint method and then execute your code to display the desired text.
In your OnMouseMove event handler, if you detect that the mouse coordinates text needs to be updated, call Invalidate on the chart.
The call to Invalidate will mark that window as being dirty and when the next paint cycle occurs, your code in Paint will be executed.
What is more, when anything else occurs that forces a paint cycle, for instance other modifications to the chart, your paint code will execute again.
Note, as an alternative to sub-classing, you can probably use the TChart event OnAfterDraw. But I'm not an expert on TChart, so am not sure. The main points though are as I state above.
From a comment you wrote, I see you followed this example.
Note it doesn't draw any rectangle; it only draws text, so I'm not sure to understand what box is following your mouse.
Also note the example calls Invalidate, as David Heffernan suggested in his answer.
Find below a modified version of the same example, painting a rectangle before the text.
procedure TForm1.FormCreate(Sender: TObject);
begin
Series1.FillSampleValues(10);
Chart1.View3D := False;
end;
procedure TForm1.Chart1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var tmpL,tmpL2,ClickedValue : Integer;
tmpWidth, tmpHeight: Integer;
tmpText: string;
begin
clickedvalue := -1;
tmpL2:= -1;
With Chart1 do
begin
If (Series1.Clicked(X, Y) <> -1) And (not OnSeriesPoint) Then
begin
Canvas.Brush.Style := bsSolid;
Canvas.Pen.Color := clBlack;
Canvas.Brush.Color := clWhite;
tmpText:=FormatFloat('#.00',Series1.XScreenToValue(x))+','+FormatFloat('#.00',Series1.YScreenToValue(y));
tmpWidth:=Canvas.TextWidth(tmpText)+10;
tmpHeight:=Canvas.TextHeight(tmpText);
Canvas.Rectangle(x+5, y, x+tmpWidth, y+tmpHeight);
Canvas.TextOut(x+10,y,tmpText);
OnSeriesPoint := True;
ClickedValue:= Series1.Clicked(x,y);
End;
//Repaint Chart to clear Textoutputted Mark
If (ClickedValue=-1) And (OnSeriesPoint) Then
begin
OnSeriesPoint := False;
Invalidate;
End;
tmpL := Chart1.Legend.Clicked(X, Y);
If (tmpL <> -1) And ((tmpL <> tmpL2) Or (not OnLegendPoint)) Then
begin
repaint;
Canvas.Brush.Color := Series1.LegendItemColor(tmpL);
Canvas.Rectangle( X, Y, X + 20, Y + 20);
Canvas.Brush.Color := clWhite;
Canvas.TextOut(x+15,y+7,FormatFloat('#.00',Series1.XValues.Items[Series1.LegendToValueIndex(tmpl)]));
tmpL2 := tmpL;
OnLegendPoint := True;
End;
If (tmpL2 = -1) And (OnLegendPoint) Then
begin
OnLegendPoint := False;
Invalidate;
End;
End;
End;
I have a TCard ( TGraphicControl component) and it has a property
background (TPicture)
I would like to be able to dim out or darken the background. Thus if i can play the card in the game then its normal. If i can not play the card in the game then its darken out. I have tried putting Tcard.enabled :=false Like you would a button, but it does not dim it out or darken the image / background.
Also I could not find a alphablend property for TPicture as i thought this might help.
With what property or component would i need to get this effect?
Handling Enabled
Following your example, the enabled state of TButton is drawn by Windows. For your own control, a visual reflection of a disabled state should be drawn by yourself. Within the overriden Paint routine this will simply mean:
if Enabled then
// draw enabled
else
// draw disabled;
The VCL takes care of handling a change of the Enabled property, since it calls Invalidate on the CM_ENABLEDCHANGED message.
Drawing dimmed
The most simple solution is to draw all that has to be drawn alphablended:
procedure TCard.Paint;
var
Tmp: TBitmap;
BlendFunc: TBlendFunction;
begin
if Enabled then
InternalPaint(Canvas)
else
begin
Tmp := TBitmap.Create;
try
Tmp.SetSize(Width, Height);
InternalPaint(Tmp.Canvas);
BlendFunc.BlendOp := AC_SRC_OVER;
BlendFunc.BlendFlags := 0;
BlendFunc.SourceConstantAlpha := 80;
BlendFunc.AlphaFormat := 0;
WinApi.Windows.AlphaBlend(Canvas.Handle, 0, 0, Width, Height,
Tmp.Canvas.Handle, 0, 0, Width, Height, BlendFunc);
finally
Tmp.Free;
end;
end;
end;
Wherein the InternalPaint routine does everything you are doing now, for example:
procedure TCard.InternalPaint(ACanvas: TCanvas);
var
R: TRect;
begin
R := ClientRect;
ACanvas.Brush.Color := clGray;
ACanvas.Rectangle(R);
InflateRect(R, -7, -7);
if (FPicture.Graphic <> nil) and (not FPicture.Graphic.Empty) then
ACanvas.StretchDraw(R, FPicture.Graphic);
end;
All this with the following result:
The SourceConstantAlpha factor (max 255) signifies by how much the temporarily bitmap is blended with the destination surface. The default color of the Canvas is the color of the Parent (assuming you do not interfere with erasing background or something), which is clBtnFace in the above image. If that destination is all white, then the bitmap is faded to white. If you would like a blending color or a darkened effect, then add these two lines before AlphaBlend:
Canvas.Brush.Color := clBlack; //or clMaroon
Canvas.FillRect(ClientRect);
Following code makes quite some troubles:
procedure TForm1.Button1Click(Sender: TObject);
var dc : HDC;
meta : TMetafile;
metaCanv : TMetafileCanvas;
cr : TRect;
sz : TSize;
begin
dc := GetDC(0);
SetWindowExtEx(dc, 4800, 1300, #sz);
ShowMessage(Format('size %d, %d', [sz.cx, sz.cy]));
meta := TMetafile.Create;
meta.SetSize(4500, 1300);
metaCanv := TMetafileCanvas.Create(meta, dc);
try
IntersectClipRect(metaCanv.Handle, 0, 0, 4600, 1300);
cr := metaCanv.ClipRect;
with cr do
ShowMessage(Format('clip rect: %d, %d, %d, %d', [Top, Left, Bottom, Right]));
finally
metaCanv.Free;
meta.Free;
end;
DeleteDC(dc);
end;
The problem is that the clipping rectangle is bound to the display resolution e.g. if your screen has 1920 pixels width the clipping rectangle is bound to this value.
Note it is NOT a problem to remove clipping at all and paint lines event to the complete bottom rect corner. The problem arises if a clipping region is set (e.g. to the complete metafile width/height as shown in the example) and then paint the line -> it is clipped to the screen width/height.
I know that I could use e.g. a printer dc as reference which will basically fix the problem but there are a few side effects (e.g. gdi+ drawing on metafiles with such
dc's simply does not work).
Anyone knows how to "trick" the system such that this odd clipping behaviour is not
there any more?
ClipRect being the only part in which you can draw is a false presumption.
The documentation on TCustomCanvas.ClipRect:
Use ClipRect to determine where the canvas needs painting.
This is easily verified by drawing beyond ClipRect and trying to show what has been drawn, for example as follows:
procedure TForm1.Button1Click(Sender: TObject);
var
MetaFile: TMetafile;
MetaCanvas: TMetafileCanvas;
begin
MetaFile := TMetafile.Create;
try
MetaCanvas := TMetafileCanvas.Create(MetaFile, 0);
try
MetaFile.SetSize(4500, 1300);
MetaCanvas.LineTo(4500, 1300);
finally
MetaCanvas.Free;
end;
Canvas.Draw(-4400, -1200, MetaFile);
finally
MetaFile.Free;
end;
end;
How can I draw something on the Forms canvas and over controls on the Form?
I try the following:
procedure TForm1.FormPaint(Sender: TObject);
var x,y: Integer;
begin
x := Mouse.CursorPos.X - 10;
y := Mouse.CursorPos.Y - 10;
x := ScreentoClient(point(x,y)).X - 10;
y := ScreenToClient(point(x,y)).Y - 10;
Canvas.Brush.Color := clRed;
Canvas.FillRect(rect(x, y, x + 10, y + 10));
Invalidate;
end;
The rectangle is drawn before other controls are drawn, so it is hidden behind the controls (this is expected behavior according to the Delphi Docs).
My questions is how can I draw over controls?
Do not 'invalidate' in a paint handler. Invalidating causes a WM_PAINT to be sent, which of course starts the paint handling all over. Even if you don't move the mouse, the code sample you posted will cause the 'OnPaint' event to run again and again. Since your drawing depends on the position of the cursor, you'd use the 'OnMouseMove' event for this. But you need to intercept mouse messages for other windowed controls as well. The below sample uses a 'ApplicationEvents' component for this reason. If your application will have more than one form, you need to device a mechanism to differentiate which form you are drawing on.
Also see on the docs that, VCL's Invalidate invalidates the entire window. You don't need to do that, you're drawing a tiny rectangle and you know exactly where you're drawing. Just invalidate where you'll draw and where you've drawn.
As for drawing on controls, actually the drawing part is easy, but you can't do that with the provided canvas. Forms have got WS_CLIPCHILDREN style, child windows' surfaces will be excluded from the update region, so you'd have to use GetDCEx or GetWindowDC. As 'user205376' mentioned in the comments, erasing what you've drawn is a bit more tricky, since you can be drawing one rectangle actually on more than one control. But the api has a shortcut for this too, as you'll see in the code.
I tried to comment a bit the code to be able to follow, but skipped error handling. The actual painting could be in the 'OnPaint' event handler, but controls which do not descend from 'TWinControl' are being painted after the handler. So it's in a WM_PAINT handler.
type
TForm1 = class(TForm)
[..]
ApplicationEvents1: TApplicationEvents;
procedure FormCreate(Sender: TObject);
procedure ApplicationEvents1Message(var Msg: tagMSG; var Handled: Boolean);
private
FMousePt, FOldPt: TPoint;
procedure WM_PAINT(var Msg: TWmPaint); message WM_PAINT;
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
// no rectangle drawn at form creation
FOldPt := Point(-1, -1);
end;
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
var
R: TRect;
Pt: TPoint;
begin
if Msg.message = WM_MOUSEMOVE then begin
// assume no drawing (will test later against the point).
// also, below RedrawWindow will cause an immediate WM_PAINT, this will
// provide a hint to the paint handler to not to draw anything yet.
FMousePt := Point(-1, -1);
// first, if there's already a previous rectangle, invalidate it to clear
if (FOldPt.X > 0) and (FOldPt.Y > 0) then begin
R := Rect(FOldPt.X - 10, FOldPt.Y - 10, FOldPt.X, FOldPt.Y);
InvalidateRect(Handle, #R, True);
// invalidate childs
// the pointer could be on one window yet parts of the rectangle could be
// on a child or/and a parent, better let Windows handle it all
RedrawWindow(Handle, #R, 0,
RDW_INVALIDATE or RDW_UPDATENOW or RDW_ALLCHILDREN);
end;
// is the message window our form?
if Msg.hwnd = Handle then
// then save the bottom-right coordinates
FMousePt := SmallPointToPoint(TSmallPoint(Msg.lParam))
else begin
// is the message window one of our child windows?
if GetAncestor(Msg.hwnd, GA_ROOT) = Handle then begin
// then convert to form's client coordinates
Pt := SmallPointToPoint(TSmallPoint(Msg.lParam));
windows.ClientToScreen(Msg.hwnd, Pt);
FMousePt := ScreenToClient(Pt);
end;
end;
// will we draw? (test against the point)
if PtInRect(ClientRect, FMousePt) then begin
R := Rect(FMousePt.X - 10, FMousePt.Y - 10, FMousePt.X, FMousePt.Y);
InvalidateRect(Handle, #R, False);
end;
end;
end;
procedure TForm1.WM_PAINT(var Msg: TWmPaint);
var
DC: HDC;
Rgn: HRGN;
begin
inherited;
if (FMousePt.X > 0) and (FMousePt.Y > 0) then begin
// save where we draw, we'll need to erase before we draw an other one
FOldPt := FMousePt;
// get a dc that could draw on child windows
DC := GetDCEx(Handle, 0, DCX_PARENTCLIP);
// don't draw on borders & caption
Rgn := CreateRectRgn(ClientRect.Left, ClientRect.Top,
ClientRect.Right, ClientRect.Bottom);
SelectClipRgn(DC, Rgn);
DeleteObject(Rgn);
// draw a red rectangle
SelectObject(DC, GetStockObject(DC_BRUSH));
SetDCBrushColor(DC, ColorToRGB(clRed));
FillRect(DC, Rect(FMousePt.X - 10, FMousePt.Y - 10, FMousePt.X, FMousePt.Y), 0);
ReleaseDC(Handle, DC);
end;
end;
The application main window cannot draw over other control surface. Controls periodically paint and erase themselves (based on the control "paint cycle")
Your application can only draw on controls that allow the application to do it. Many common controls provide flexibility to applications for customizing the control appearance, thru control custom draw techniques.
You can't.
Controls are drawn on top of their parent window. Whatever you draw on the parent window will be seen behind the controls over that window. It is not clear why you need to do such a drawing; however, maybe you can create a transparent control inside the form and set it to front, then draw on its canvas. That way your drawing would look on top of the form and its other controls, but that way user cannot interact with other controls on the form, because they are behind the transparent control.
You cannot do this. You need to create a windowed control (such as a window) and place this window on top of the controls you want to draw "on". Then you can either
copy the bitmap of the form with controls, and use this bitmap as the background image of this new control, or
make this new window have an irregular shape, so that it is transparent outside some irregularly shaped region.
I did something who involve to draw handles around components on my form here what I did.
First create a message like this :
Const
PM_AfterPaint = WM_App + 1;
Write a Procedure to handle the message:
Procedure AfterPaint(var msg: tmsg); Message PM_AfterPaint;
Procedure AfterPaint(var msg: tmsg);
begin
{place the drawing code here}
ValidateRect(Handle, ClientRect);
end;
Validaterect will tell Windows that there is no need to repaint your form. Your painting will cause portion of the form to be "invalidate". ValidateRect say to windows everything is "validate".
You also need, last step, to override the paint procedure.
Procedure Paint; Override;
Procedure TForm1.paint;
Begin
Inherited;
PostMessage(Handle, PM_AfterPaint, 0, 0);
End;
So each time your form need to be repainted (WM_Paint), it will call the ancestor paint and add a AfterPaint message to the message queue. When The message is process, AfterPaint is call and do paint your stuff and tell Windows that everything is fine, preventing another call to paint.
Hope this help.