FPercentDone was 0, was assigning it's value in the wrong place. Adding UpdatePercent procedure and calling it when a value changes fixes it and everything gets drawn.
Dumb mistake, sorry for wasting your time.
First of all, this is my first attempt at writing a component of any kind. Properties, methods etc. were an easy part, however I have hit a wall with drawing to the canvas. I am sure this is some rookie mistake, but I simply don't see it. I have stared at the TGauge included with delphi because I am trying something similar but simpler, it is still just a horizontal bar. I am failing at making it draw the progress at run time, that is the weirdest part, for me anyway, that I can see it working at design time but not when I run it... I do get the background coloring right at least, but no progress bar.
Without any code pasting, since it is similar to TGauge anyway. I have two TBitmap's, one for background the other for the progress bar itself, I fill one with background color, draw that to the component canvas, if there are borders offset the origin of the second one and decrease its rectangle, paint it with the progress color and draw that to the canvas... It seemed this simple to me, but what am I doing wrong?
Relevant code:
type
TCustomGaugeComp = class(TGraphicControl)
private
FMaxValue, FMinValue, FCurValue: DWord;
FFillBackColor, FFillForeColor: TColor;
FPercentDone: Real;
FBorderStyle: TBorderStyle;
FBorderWidth: Integer;
procedure SetMaxValue(Value: DWord);
procedure SetMinValue(Value: DWord);
procedure SetProgress(Value: DWord);
procedure SetFillBackColor(Value: TColor);
procedure SetFillForeColor(Value: TColor);
procedure SetBorderStyle(Value: TBorderStyle);
function GetPercentDone: String;
procedure SetBorderWidth(Value: integer);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
published
property Align;
property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
property BorderWidth: Integer read FBorderWidth write SetBorderWidth default 1;
property Constraints;
property Enabled;
property Font;
property FillForeColor: TColor read FFillForeColor write SetFillForeColor default clBlack;
property FillBackColor: TColor read FFillBackColor write SetFillBackColor default clWhite;
property MinValue: DWord read FMinValue write SetMinValue default 0;
property MaxValue: DWord read FMaxValue write SetMaxValue default 100;
property Progress: DWord read FCurValue write SetProgress default 0;
property PercentDone: String read GetPercentDone;
property Visible;
end;
procedure TCustomGaugeComp.Paint;
var
Background, Progress: TBitMap;
begin
with Canvas do
begin
Background := TBitMap.Create;
try
Background.Height := Height;
Background.Width := Width;
Background.Canvas.Brush.Color := FFillBackColor;
Background.Canvas.Brush.Style := bsSolid;
Background.Canvas.FillRect(ClientRect);
Progress := TBitMap.Create;
try
Progress.Height := Height;
Progress.Width := Width;
if FBorderStyle = bsSingle then
begin
Progress.Height := Progress.Height - BorderWidth*2;
Progress.Width := Progress.Width - BorderWidth*2;
end;
Progress.Width := trunc(Progress.Width*FPercentDone/100);
Progress.Canvas.Brush.Color := FFillForeColor;
Progress.Canvas.FillRect(Rect(0,0,Progress.Width,Progress.Height));
Background.Canvas.Draw(BorderWidth,BorderWidth,Progress);
finally
Progress.Free;
end;
Draw(0,0,Background);
finally
Background.Free;
end;
end;
end;
RePaint (or Refresh) is called whenever a value changes: min/max/position/borderwidth.
In fact it is not acting perfectly at design time either, progress is drawn, at times, sometimes not drawn at all until I just OPEN the Object Inspector, just go with my mouse there... TGauge uses CopyMode excessively, I just started this and I do not really understand CopyMode values yet or its proper use, so copy-pasting and tweaking the code just will not do.
FPercentDone was 0, was assigning it's value in the wrong place. Adding UpdatePercent procedure and calling it when a value changes fixes it and everything gets drawn.
Dumb mistake, sorry for wasting your time.
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.
The scenario is this:
I've created a Delphi (XE2) form.
On it is a single TGroupBox (or other control) stretched so it occupies the full width of the form with the top.
Right anchor (in addition to left and top) on TGroupBox is set.
Form width set to 1200px (to illustrate the point).
If I run this application on a monitor whose Screen.Width property is greater than 1200px (I'm running without any DPI virtualization AFAIK) then the TGroupBox renders as you'd expect.
However.. if the monitor's width is less than 1200px then the right hand portion of the control is missing from the screen regardless of how your resize the form.
I've overridden the Create() method of my form with the override; directive and verified that I'm setting the width property correctly, however the control is still cropped.
Can anyone advise either how to:
a) set the width property of the form such that it is affects the positioning of the child components or...
b) suggest a way to force a relayout of all child components once the form is rendered?
Tracing the code to see what happens, I came up with the below adjustment.
procedure TForm1.WMWindowPosChanging(var Message: TWMWindowPosChanging);
var
MessageWidth: Integer;
begin
MessageWidth := Message.WindowPos.cx;
inherited;
if MessageWidth > Message.WindowPos.cx then
GroupBox1.Width := GroupBox1.Width - MessageWidth + Message.WindowPos.cx;
end;
This is not a generalized solution, but it makes clear what the problem is. VCL asks for a window size for its form which is not granted by the OS since it is larger then the desktop. From then on the form resumes anchoring the child control with its design time specified width which is larger than the client width of the form, thus right side of the child control overflows.
Another solution can be to override handling of WM_GETMINMAXINFO message to let the OS grant the asked width.
procedure TForm1.WMGetMinMaxInfo(var Message: TWMGetMinMaxInfo);
begin
inherited;
Message.MinMaxInfo.ptMaxTrackSize.X := 1200;
end;
This may not be a good solution because then the form will be larger than the desktop.
Regarding your 'a' and 'b' items, I don't think 'b' is possible - or at least not possible to make the VCL relayout by itself - because VCL defers applying anchor rules until after the component (form) is done loading. By then, the form's width is different than the design time width but child controls' placement remain unaffected. No amount of forcing to layout will make them in sync again.
However it should possible to recalculate everything from scratch if your own code keeps a reference to the design time width. Below is not complete code.
type
TForm1 = class(TForm)
..
private
FAdjustShrinkWidth, FAdjustShrinkHeight: Integer;
protected
procedure Loaded; override;
public
procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer;
AHeight: Integer); override;
end;
...
procedure TForm1.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
TrackWidth, TrackHeight: Boolean;
begin
TrackWidth := AWidth = 1200;
TrackHeight := AHeight = ??;
inherited;
if TrackWidth and (Width < AWidth) then
FAdjustShrinkWidth := AWidth - Width;
if TrackHeight and (Height < AHeight) then
FAdjustShrinkHeight := AHeight - Height;
end;
procedure TForm1.Loaded;
procedure ReadjustControlAnchors(Control: TWinControl);
var
i: Integer;
begin
for i := 0 to Control.ControlCount - 1 do
if (akRight in Control.Controls[i].Anchors) or (akBottom in Control.Controls[i].Anchors) then begin
Control.Controls[i].Left := // some complex calculation depending on the anchors set;
Control.Controls[i].Top := // same as above;
Control.Controls[i].Width := // same as above;
Control.Controls[i].Height := // same as above;
if (Control.Controls[i] is TWinControl) and (TWinControl(Control.Controls[i]).ControlCount > 0) then
ReadjustControlAnchors(TWinControl(Control.Controls[i]));
end;
end;
begin
inherited;
ReadjustControlAnchors(Self);
end;
I have no idea how to fill in the blanks in the above code. Reading and tracing VCL code may be compulsory to imitate VCL anchoring.
I can't think of anything for 'a'.
Update:
VCL has actually left a backdoor for a control to lie to its immediate children about their parent's size while they are anchoring. Documentation explains it a bit different:
UpdateControlOriginalParentSize is a protected method that updates the
original size of the parent control. It is used internally to update
the anchor rules of the control.
We can use it to tell the groupbox the intended original size.
type
TForm1 = class(TForm)
..
private
FWidthChange, FHeightChange: Integer;
protected
procedure UpdateControlOriginalParentSize(AControl: TControl;
var AOriginalParentSize: TPoint); override;
public
procedure SetBounds(ALeft: Integer; ATop: Integer; AWidth: Integer;
AHeight: Integer); override;
end;
...
procedure TForm1.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
var
RequestedWidth, RequestedHeight: Integer;
begin
RequestedWidth := AWidth;
RequestedHeight := AHeight;
inherited;
if csLoading in ComponentState then begin
if RequestedWidth <> Width then
FWidthChange := Width - AWidth;
if RequestedHeight <> Height then
FHeightChange := Height - AHeight;
end;
end;
procedure TForm1.UpdateControlOriginalParentSize(AControl: TControl;
var AOriginalParentSize: TPoint);
begin
inherited;
if akRight in AControl.Anchors then
AOriginalParentSize.X := AOriginalParentSize.X - FWidthChange;
if akBottom in AControl.Anchors then
AOriginalParentSize.Y := AOriginalParentSize.Y - FHeightChange;
end;
I note again that this will affect the form's immediate children only. Should the groupbox hosts controls that anchors right and bottom, it also has to override the same method.
Also note that this will not undo the fact that the form's width has changed. That's if there was a left anchored control that's at the far right of the form, it will not replace itself to client boundary. It will act as if the form's width has been decreased, i.e. remain out of sight.
I've recently started converting an application to FireMonkey, and started with the simple controls. For some reason, their position is off, compared to dropped components on the form like say TPanel or TButton. From my tests, it appears the position is doubled.
My test project is simple: (in Delphi XE5)
create a new firemonkey HD application
drop a panel on the form at position (100,100) right click on it and "send to back"
paste the following code (adapt names where needed) for the custom component
code:
type
TTest = class(TPaintBox)
private
FBitmap: TBitmap;
public
Constructor Create(AOwner:TComponent); override;
Destructor Destroy; override;
procedure Paint; override;
end;
{ TTest }
constructor TTest.Create(AOwner: TComponent);
begin
inherited;
FBitmap := TBitmap.Create;
FBitmap.LoadFromFile('c:\test.png');
Width := FBitmap.Width;
Height := FBitmap.Height;
end;
destructor TTest.Destroy;
begin
FreeAndNil(FBitmap);
inherited;
end;
procedure TTest.Paint;
begin
Canvas.DrawBitmap(FBitmap,
TRectf.Create(0, 0, FBitmap.Width, FBitmap.Height),
AbsoluteRect,
1);
end;
paste the following code to dynamically create the above component
code:
procedure TForm2.FormCreate(Sender: TObject);
var t: TTest;
begin
t := TTest.Create(self);
t.Parent := self;
t.Position.X := 50;
t.Position.Y := 50;
end;
Build it for Win32.
On my end, the image appears in the upper left corner for the panel, which is at 100,100 but the control is clearly set to position itself at 50,50
Debugging shows correct values on positions and rects.
I can't figure out what is going on. Maybe somebody has some suggestions/explanations.
Thanks.
AbsoluteRect ist the rectangle of the Control relative to it's Form. If you want to paint something you have to use local coordinates, in this case LocalRect.
Canvas.DrawBitmap(FBitmap, TRectf.Create(0, 0, FBitmap.Width, FBitmap.Height), LocalRect, 1);
I'm trying to use TCustomHint to show a message to my user that fades in and out nicely, to not be too distracting. However when I call ShowHint on my object with a point, the hint box appears to center itself around the point I give. What I would like is to have my box appear such that its top-left coordinate is the point given.
Here's the code I'm using so show the hint:
procedure ShowNotification(ATitle: UnicodeString; AMsg: UnicodeString);
var
Box: TCustomHint;
P: TPoint;
begin
Box := TCustomHint.Create(MyForm);
Box.Title := ATitle;
Box.Description := AMsg;
Box.Delay := 0;
Box.HideAfter := 5000;
Box.Style := bhsStandard;
P.X := 0;
P.Y := 0;
Box.ShowHint(P);
end;
I know that my point's X/Y coordinates are not relative to the form, and that's not the issue.
I've traced through what happens when I call ShowHint and it appears that if I can somehow control the final width of the underlying TCustomHintWindow inside of TCustomHint.ShowHint(Rect: TRect) then I may be in business.
So my question is: is there an obvious way to stop a TCustomHint from centering itself at my point? Or will I have to go through the process of inheriting, overriding the draw method, etc etc? I hope I'm just missing something simple.
There's no particularly easy way to do what you want. The TCustomHint class is designed to serve a very specific purpose. It was designed to be used by the TControl.CustomHint property. You can see how it is called by looking at the code for TCustomHint.ShowHint. The pertinent excerpts are:
if Control.CustomHint = Self then
begin
....
GetCursorPos(Pos);
end
else
Pos := Control.ClientToScreen(Point(Control.Width div 2, Control.Height));
ShowHint(Pos);
So, either the control is shown centred horizontally around the current cursor position, or centred horizontally around the middle of the associated control.
I think the bottom line here is that TCustomHint is not designed to be used the way you are using it.
Anyway, there is a rather gruesome way to make your code do what you want. You can create a temporary TCustomHintWindow that you never show and use it to work out the width of the hint window that you want to show. And then use that to shift the point that you pass to the real hint window. In order to make it fly you need to crack the private members of TCustomHintWindow.
type
TCustomHintWindowCracker = class helper for TCustomHintWindow
private
procedure SetTitleDescription(const Title, Description: string);
end;
procedure TCustomHintWindowCracker.SetTitleDescription(const Title, Description: string);
begin
Self.FTitle := Title;
Self.FDescription := Description;
end;
procedure ShowNotification(ATitle: UnicodeString; AMsg: UnicodeString);
var
Box: TCustomHint;
SizingWindow: TCustomHintWindow;
P: TPoint;
begin
Box := TCustomHint.Create(Form5);
Box.Title := ATitle;
Box.Description := AMsg;
Box.Delay := 0;
Box.HideAfter := 5000;
Box.Style := bhsStandard;
P := Point(0, 0);
SizingWindow := TCustomHintWindow.Create(nil);
try
SizingWindow.HintParent := Box;
SizingWindow.HandleNeeded;
SizingWindow.SetTitleDescription(ATitle, AMsg);
SizingWindow.AutoSize;
inc(P.X, SizingWindow.Width div 2);
finally
SizingWindow.Free;
end;
Box.ShowHint(P);
end;
This does what you asked, but honestly, it makes me feel rather queasy.
Background
I/m building a custom FireMonkey GUI control. I want to render the control to a back buffer. The back buffer will be drawn on the control's canvas.
The back buffer is a Fmx.TBitmap object.
I am using a back buffer because the control rendering code is a little involved and does not need to be called each time the control is repainted. The back buffer will only be updated when some control properties change.
Problem
The BackBuffer.Canvas drawing operations have no visible effect. However clearing the bitmap, or setting the value of the bitmap pixels individually do work as expected.
For some reason the BackBuffer.Canvas object will not draw on the back buffer bitmap.
I think I've set the required Canvas.Fill properties correctly.
All the canvas properties I've checked appear to be correct. (Canvas width/height/etc)
I've extracted the relevant code in case that contains some clues.
TMyControl(TControl)
private
protected
BackBuffer : TBitmap;
procedure Paint; override;
procedure Resize; override;
public
constructor Create(AOwner: TComponent); override;
end;
constructor TMyControl.Create(AOwner: TComponent);
begin
inherited;
BackBuffer := TBitmap.Create(10, 10);
end;
procedure TFxSampleDisplay.Resize;
var
w, h : integer;
begin
inherited;
// Ensure BackBuffer is the same size as the control.
w := round(BoundsRect.Width);
h := round(BoundsRect.Height);
BackBuffer.SetSize(w,h);
end;
procedure TMyControl.Paint;
var
r : TRectF;
begin
inherited;
//******** This has visible results ********
BackBuffer.Clear($1100ff00); // Fill with semi-opaque green background
BackBuffer.Pixels[2,2] := $ffff0000; // Draw a red pixel
//******** This doesn't have visible results ********
r.Left := 0;
r.Top := 0;
r.Right := 50;
r.Bottom := 50;
BackBuffer.Canvas.Fill.Color := $ffff0000; // Set fill to RED.
BackBuffer.Canvas.Fill.Kind := TBrushKind.bkSolid;
BackBuffer.Canvas.FillRect(r, 10,10, AllCorners, 1);
//******** Draw the backbuffer on to the controls canvas ********
Canvas.DrawBitmap(BackBuffer, BoundsRect, BoundsRect, 1);
end;
Try surrounding your drawing with:
BackBuffer.Canvas.BeginScene;
..
..
BackBuffer.Canvas.EndScene;
BackBuffer.BitmapChanged;
P.S. I'm pretty new with FireMonkey style, so just try it out and write if it worked please!