I'm trying to draw in each cell of a TGridPanel overriding the Paint event. I get the Rect for each cell through CellRect [Row, Col]. This works until an edge is reported. In this case, even the design in designtime is wrong: the 'ClientRect' of the cells do not correspond to the return of CellRect.
I tried to adjust the rect obtained from CellRect, but it is very complex to consider the displacement rate for each. In the image below, I have a TGripanel with a 3px border and each panel with AlignwithMargins = true, all Margins = 3px.
Has anyone ever experienced this?
Native Paint:
BorderWidth = 3
BorderStyle = bsNone
(each panel is align = alclient and AlignWithMargins = True
My code to get cells 'ClientRect':
procedure TMyCustomGridPanel.paint;
var
Row, Col: Integer;
rctCell: TRect;
function GetColor(C, R: Integer): TColor;
begin
if odd(C + R) then
Result:= clblack
else
Result:= clWhite;
end;
begin
inherited;
for Row := 0 to RowCollection.Count -1 do
begin
for Col := 0 to ColumnCollection.Count -1 do
begin
Canvas.Brush.Color := GetColor(Col, Row);
if Canvas.Brush.Color <> clDefault then
begin
rctCell := CellRect[Col, Row];
{$REGION 'Adjust first col an row'}
if Col = 0 then
rctCell.SetLocation(rctCell.Location.X + BorderWidth, rctCell.Location.Y);
if Row = 0 then
rctCell.SetLocation(rctCell.Location.X, rctCell.Location.Y + BorderWidth);
{$ENDREGION}
{$REGION 'ajust last cells'}
if Col = (ColumnCollection.Count -1) then
begin
if Col > 0 then // tem mais de uma coluna
rctCell.SetLocation(rctCell.Location.X - BorderWidth, rctCell.Location.Y);
rctCell.Right := ClientRect.Right;
end;
if Row = (RowCollection.Count -1) then
begin
if Row > 0 then
rctCell.SetLocation(rctCell.Location.X, rctCell.Location.Y - BorderWidth);
rctCell.Bottom := ClientRect.Bottom;
end;
{$ENDREGION}
Canvas.Pen.Style := psClear;
Canvas.FillRect(rctCell);
end;
end;
end;
end;
Result with my code:
(the panels are just to show that CellRect is not the 'ClientRect' to put a control)
GridPanel
BorderWidth = 10
BorderStyle = bsNone
Color = clmarron
Panels
Align = alClient
Color = clgray
AlignWithMargins = true
Design time rendering of the cell borders (the dotted lines) of a TGridPanel does not take into account the borders of the panel. Thus they do not visually coincide with components you have placed in the grid cells. This is most apparent e.g. with panels of which the Align property is set to alClient.
To know the actual rectangle of a cell, in coordinates of the TGridPanel, you can use OffsetRect to adjust for the border widths.
var
row, col: integer;
r: TRect;
begin
...
r := CellRect[Col, Row];
OffsetRect(r, BorderWidth, BorderWidth);
I have several task on button click.
eg.
Show form or please wait panel....
Load data from database (duration 5-10 seconds)
Clear all TEdit field
Hide form or please wait panel....
ShowMessage('completed')
Is it possible After click on button show please wait panel or form and after all completed hide that panel.
How to Synchronize Perform Tasks One by one.
Or any other simple solution.
This is a simple example that creates a "placeholder" which looks like this:
The rectangle has a black background and contains a layout which is aligned to Center; inside you can find a label (aligned to Top) and an arc (aligned to Client). The code is here:
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 418
ClientWidth = 490
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
OnCreate = FormCreate
DesignerMasterStyle = 0
object Rectangle1: TRectangle
Align = Client
Fill.Color = xFF222222
Size.Width = 490.000000000000000000
Size.Height = 418.000000000000000000
Size.PlatformDefault = False
Visible = False
object Layout1: TLayout
Align = Center
Size.Width = 170.000000000000000000
Size.Height = 102.000000000000000000
Size.PlatformDefault = False
TabOrder = 0
object Label1: TLabel
Align = Top
StyledSettings = [Family, Size, Style]
Size.Width = 170.000000000000000000
Size.Height = 41.000000000000000000
Size.PlatformDefault = False
TextSettings.FontColor = claWhite
TextSettings.HorzAlign = Center
Text = 'Please wait'
TabOrder = 0
end
object Arc1: TArc
Align = Center
Size.Width = 50.000000000000000000
Size.Height = 50.000000000000000000
Size.PlatformDefault = False
Stroke.Color = claCoral
EndAngle = -90.000000000000000000
object FloatAnimation1: TFloatAnimation
Enabled = True
Duration = 1.000000000000000000
Loop = True
PropertyName = 'RotationAngle'
StartValue = 0.000000000000000000
StopValue = 360.000000000000000000
end
end
end
end
end
The Visible property of the rectangle is set to False so that you won't see immediately the rectangle. Note that I have created an animation in the arc component so that you can see it spinning around:
In this way you can mimic a loading spinner. Then I have added this code in the OnCreate event of the form just as example of how you could do this.
procedure TForm1.FormCreate(Sender: TObject);
begin
TTask.Run(procedure
begin
TThread.Synchronize(nil, procedure
begin
Rectangle1.Visible := true;
//Rectangle1.BringToFront;
// ^ call the above if needed, just to be sure
// that you'll always see the rectangle on screen
end);
Sleep(4000);
TThread.Synchronize(nil, procedure
begin
Rectangle1.Visible := false;
ShowMessage('Finish!');
end);
end);
end;
The Sleep(4000) simulates a long task and this piece of code should be replaced with your tasks. Actually I'd do something like this:
procedure TForm1.FormCreate(Sender: TObject);
begin
TTask.Run(procedure
var
arr: array [0..1] of ITask;
begin
TThread.Synchronize(nil, procedure
begin
Rectangle1.Visible := true;
Rectangle1.BringToFront;
end);
arr[0] := TTask.Run(procedure
begin
//load data from the database
end);
arr[1] := TTask.Run(procedure
begin
//something else
end);
//this call is blocking but you are calling this in a worker thread!
//your UI won't freeze and at the end you'll see the message appearing
TTask.WaitForAll(arr);
TThread.Synchronize(nil, procedure
begin
Rectangle1.Visible := false;
ShowMessage('Finish!');
end);
end);
end;
Of course you should place this code in a ButtonClick and not in a FormCreate event handler!
I have custom styled FireMonkey control. Its style contains several levels of nested controls.
I need to access those controls and change some style properties at run-time. To do that I am using FindStyleResource<T> method.
I have no problem in retrieving first level of controls inside style. But accessing controls on second level with FindStyleResource fails if control parent is descendant of TStyledControl.
Question is how to access those nested style controls regardless of their parent type?
Style:
object TStyleContainer
object TLayout
StyleName = 'MyHeader'
Align = Center
Size.Width = 100.000000000000000000
Size.Height = 50.000000000000000000
Size.PlatformDefault = False
Visible = False
TabOrder = 0
object TLabel
StyleName = 'title'
Align = Client
StyledSettings = [Style]
Size.Width = 36.000000000000000000
Size.Height = 50.000000000000000000
Size.PlatformDefault = False
TextSettings.HorzAlign = Center
Text = 'Title'
end
object TLayout
StyleName = 'green'
Align = MostLeft
Size.Width = 32.000000000000000000
Size.Height = 50.000000000000000000
Size.PlatformDefault = False
object TPath
StyleName = 'greenpath'
Align = Fit
Data.Path = {
07000000000000000000404100000041010000000000C0400000604101000000
B81EED405C8F76410100000000004041AE472D410100000052B884415C8F7641
010000000000904100006041030000000000404100000041}
Fill.Color = claGreen
HitTest = False
Size.Width = 32.000000000000000000
Size.Height = 50.000000000000000000
Size.PlatformDefault = False
Stroke.Kind = None
WrapMode = Fit
end
end
object TSpeedButton
StyleName = 'red'
Align = MostRight
Position.X = 68.000000000000000000
Size.Width = 32.000000000000000000
Size.Height = 50.000000000000000000
Size.PlatformDefault = False
object TPath
StyleName = 'redpath'
Align = Fit
Data.Path = {
07000000000000000000404100000041010000000000C0400000604101000000
B81EED405C8F76410100000000004041AE472D410100000052B884415C8F7641
010000000000904100006041030000000000404100000041}
Fill.Color = claRed
HitTest = False
Size.Width = 32.000000000000000000
Size.Height = 32.571426391601560000
Size.PlatformDefault = False
Stroke.Kind = None
WrapMode = Fit
end
end
end
end
Control:
type
TMyHeader = class(TStyledControl)
protected
procedure ApplyStyle; override;
function GetDefaultStyleLookupName: string; override;
end;
procedure TMyHeader.ApplyStyle;
var
LGreen: TLayout;
LGreenPath: TPath;
LRed: TSpeedButton;
LRedPath: TPath;
begin
inherited;
if FindStyleResource<TLayout>('green', LGreen) then
begin
// following call will find greenpath control
if FindStyleResource<TPath>('greenpath', LGreenPath) then
LGreenPath.Fill.Color := TAlphaColorRec.Blue;
end;
if FindStyleResource<TSpeedButton>('red', LRed) then
begin
// following call will fail to find find redpath control
if FindStyleResource<TPath>('redpath', LRedPath) then
LRedPath.Fill.Color := TAlphaColorRec.Blue;
// this variant also fails
if LRed.FindStyleResource<TPath>('redpath', LRedPath) then
LRedPath.Fill.Color := TAlphaColorRec.Blue;
end;
end;
function TMyHeader.GetDefaultStyleLookupName: string;
begin
Result := 'MyHeader';
end;
Original style:
Changed style (only green arrow color was successfully changed)
In ApplyStyle method I can access greenpath from the style and change its color to blue. Hoewever, I cannot get redpath using FindStyleResource method.
The standard way to access style elements is via TFMXObject and iterate the children style objects.
Try this:
procedure TMyHeader.ApplyStyle;
var
objFMX,
inObjFMX: TFMXObject;
LRed: TSpeedButton;
LRedPath: TPath;
begin
inherited;
objFMX:=FindStyleResource('red');
if assigned(objFMX) and (objFMX is TSpeedButton) then
begin
LRed:=objFMX as TSpeedButton;
inObjFMX:=LRed.FindStyleResource('redpath');
if assigned(inObjFMX) and (inObjFMX is TPath) then
begin
LRedPath:=inObjFMX as TPath;
LRedPath.Fill.Color := TAlphaColorRec.Blue;
end;
end
end;
Updated Code: The FindStyleResource does not work in the above code. A different approach is followed below.
procedure TMyHeader.ApplyStyle;
var
objFMX,
inObjFMX: TFMXObject;
LRedPath: TPath;
begin
inherited;
objFMX:=FindStyleResource('red');
if assigned(objFMX) and (objFMX is TSpeedButton) then
begin
for inObjFMX in objFMX.Children do
begin
if inObjFMX is TPath then
begin
LRedPath:=inObjFMX as TPath;
LRedPath.Fill.Color:=TAlphaColorRec.Blue;
Break;
end;
end;
end;
end;
That works on 10.2
I have come across a rather funny issue. I have a form with its Fill set to Gradient.
On Windows, IOS and OSX, the gradient is drawn as it should be. But on Android, the colors are wrong. Any ideas?
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 480
ClientWidth = 640
Fill.Kind = Gradient
Fill.Gradient.Points = <
item
Color = xFFFFC600
Offset = 0.000000000000000000
end
item
Color = xFFFFF100
Offset = 1.000000000000000000
end>
Fill.Gradient.StartPosition.Y = 0.500000000000000000
Fill.Gradient.StopPosition.X = 1.000000000000000000
Fill.Gradient.StopPosition.Y = 0.500000000000000000
FormFactor.Width = 320
FormFactor.Height = 480
FormFactor.Devices = [Desktop]
DesignerMasterStyle = 0
object Button1: TButton
Position.X = 8.000000000000000000
Position.Y = 8.000000000000000000
TabOrder = 0
Text = 'Button1'
end
end
Windows:
OSX:
IOS:
Android:
You are using Delphi, right? Because, I have never seen that syntax used in a Pascal based language, nor was I able to get your code running under Delphi 10 Seattle. Was it created by a code-generator?
I have, however, written up the gradient you were trying to get using Delphi 10 Seattle and Firemonkey.
It works and looks the same on every device, even on Android:
procedure TForm1.FormPaint(Sender: TObject; Canvas: TCanvas;
const ARect: TRectF);
var
locGradient: TGradient;
begin
with Canvas do begin
BeginScene;
// Create and initialize the gradient object
locGradient := TGradient.Create;
with locGradient do begin
Color := $FFFFC600;
Color1 := $FFFFF100;
StartPosition .Y := 0.5;
StopPosition .X := 1;
StopPosition .Y := 0.5;
end;
// Assign the created gradient object to the fill property of the canvas
with Fill do begin
Kind := TBrushKind.Gradient;
Gradient := locGradient;
end;
// Create a rectangle which represents the gradient
FillRect( ARect, 0, 0, AllCorners, 1.0 );
EndScene;
end;
FreeAndNIL( locGradient );
end;
This doesn't necessarily answer your question as to why your colour values are messed up on Android only using your code, but then again, your code doesn't seem to follow the common Delphi syntax convention.
The Options dialog in Word 2010 implements the category selector via set of white "toggle" buttons that become orange when clicked (selected).
How would one re-implement such behavior in Delphi? A conformance with the current Windows theme is required (i.e. it must be possible to specify the button color as clWindow, not clWhite).
EDIT: To clarify - I only have problems with the category selector on the left. Everything else is fairly simple.
You could use the TButtonGroup component.
Using VCL Styles is by far the easiest solution but as like you said, using styles in XE2 is quite uncomfortable, in my opinion this feature only really became viable in XE3.
Per your request to use the default painting methods I'm submitting my solution,
source code of the project available here.
This project requires an image, the image is zipped together with the project.
Compiled and tested in XE4.
type
TButtonGroup = class(Vcl.ButtonGroup.TButtonGroup)
protected
procedure Paint; override;
end;
TForm1 = class(TForm)
ButtonGroup1: TButtonGroup;
Panel1: TPanel;
procedure ButtonGroup1DrawButton(Sender: TObject; Index: Integer;
Canvas: TCanvas; Rect: TRect; State: TButtonDrawState);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
MBitmap : TBitmap;
implementation
{$R *.dfm}
procedure TButtonGroup.Paint;
var
R : TRect;
begin
inherited;
R := GetClientRect;
R.Top := Self.Items.Count * Self.ButtonHeight;
{Remove the clBtnFace background default Painting}
Self.Canvas.FillRect(R);
end;
procedure TForm1.ButtonGroup1DrawButton(Sender: TObject; Index: Integer;
Canvas: TCanvas; Rect: TRect; State: TButtonDrawState);
var
TextLeft, TextTop: Integer;
RectHeight: Integer;
ImgTop: Integer;
Text : String;
TextOffset: Integer;
ButtonItem: TGrpButtonItem;
InsertIndication: TRect;
DrawSkipLine : TRect;
TextRect: TRect;
OrgRect: TRect;
begin
//OrgRect := Rect; //icon
Canvas.Font := TButtonGroup(Sender).Font;
if bdsSelected in State then begin
Canvas.CopyRect(Rect,MBitmap.Canvas,
System.Classes.Rect(0, 0, MBitmap.Width, MBitmap.Height));
Canvas.Brush.Color := RGB(255,228,138);
end
else if bdsHot in State then
begin
Canvas.Brush.Color := RGB(194,221,244);
Canvas.Font.Color := clBlack;
end
else
Canvas.Brush.color := clWhite;
if not (bdsSelected in State)
then
Canvas.FillRect(Rect);
InflateRect(Rect, -2, -1);
{ Compute the text location }
TextLeft := Rect.Left + 4;
RectHeight := Rect.Bottom - Rect.Top;
TextTop := Rect.Top + (RectHeight - Canvas.TextHeight('Wg')) div 2; { Do not localize }
if TextTop < Rect.Top then
TextTop := Rect.Top;
if bdsDown in State then
begin
Inc(TextTop);
Inc(TextLeft);
end;
ButtonItem := TButtonGroup(Sender).Items.Items[Index];
TextOffset := 0;
{ Draw the icon - if you need to display icons}
// if (FImages <> nil) and (ButtonItem.ImageIndex > -1) and
// (ButtonItem.ImageIndex < FImages.Count) then
// begin
// ImgTop := Rect.Top + (RectHeight - FImages.Height) div 2;
// if ImgTop < Rect.Top then
// ImgTop := Rect.Top;
// if bdsDown in State then
// Inc(ImgTop);
// FImages.Draw(Canvas, TextLeft - 1, ImgTop, ButtonItem.ImageIndex);
// TextOffset := FImages.Width + 1;
// end;
{ Show insert indications }
if [bdsInsertLeft, bdsInsertTop, bdsInsertRight, bdsInsertBottom] * State <> [] then
begin
Canvas.Brush.Color := clSkyBlue;
InsertIndication := Rect;
if bdsInsertLeft in State then
begin
Dec(InsertIndication.Left, 2);
InsertIndication.Right := InsertIndication.Left + 2;
end
else if bdsInsertTop in State then
begin
Dec(InsertIndication.Top);
InsertIndication.Bottom := InsertIndication.Top + 2;
end
else if bdsInsertRight in State then
begin
Inc(InsertIndication.Right, 2);
InsertIndication.Left := InsertIndication.Right - 2;
end
else if bdsInsertBottom in State then
begin
Inc(InsertIndication.Bottom);
InsertIndication.Top := InsertIndication.Bottom - 2;
end;
Canvas.FillRect(InsertIndication);
//Canvas.Brush.Color := FillColor;
end;
if gboShowCaptions in TButtonGroup(Sender).ButtonOptions then
begin
{ Avoid clipping the image }
Inc(TextLeft, TextOffset);
TextRect.Left := TextLeft;
TextRect.Right := Rect.Right - 1;
TextRect.Top := TextTop;
TextRect.Bottom := Rect.Bottom -1;
Text := ButtonItem.Caption;
Canvas.TextRect(TextRect, Text, [tfEndEllipsis]);
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
MBitmap := TBitmap.Create;
try
MBitmap.LoadFromFile('bg.bmp');
except
on E : Exception do
ShowMessage(E.ClassName+' error raised, with message : '+E.Message);
end;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
MBitmap.Free;
end;
DFM :
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 398
ClientWidth = 287
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
StyleElements = []
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
AlignWithMargins = True
Left = 5
Top = 5
Width = 137
Height = 388
Margins.Left = 5
Margins.Top = 5
Margins.Right = 5
Margins.Bottom = 5
Align = alLeft
BevelKind = bkFlat
BevelOuter = bvNone
Color = clWhite
ParentBackground = False
TabOrder = 0
StyleElements = [seFont]
object ButtonGroup1: TButtonGroup
AlignWithMargins = True
Left = 4
Top = 4
Width = 125
Height = 378
Margins.Left = 4
Margins.Top = 4
Margins.Right = 4
Margins.Bottom = 2
Align = alClient
BevelInner = bvNone
BevelOuter = bvNone
BorderStyle = bsNone
ButtonOptions = [gboFullSize, gboGroupStyle, gboShowCaptions]
DoubleBuffered = True
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Segoe UI'
Font.Style = []
Items = <
item
Caption = 'General'
end
item
Caption = 'Display'
end
item
Caption = 'Proofing'
end
item
Caption = 'Save'
end
item
Caption = 'Language'
end
item
Caption = 'Advanced'
end>
ParentDoubleBuffered = False
TabOrder = 0
OnDrawButton = ButtonGroup1DrawButton
end
end
end
There is a Panel container in there hosting the TButtonGroup, it is not needed, simply added for visual improvement.
If you want to change the color of the selection at runtime then I suggest using efg's Hue/Saturation method to change the Hue of the image, that way the color panel remains but the color will change.
To gain support for VCL Styles simply detach the ButtonGroup1DrawButton Event from the TButtonGroup component, that way the default DrawButton Event can kick in which adds support for that.
You can use a TListBox with style set to lbOwnerDrawFixed (if the size of the spacing isn't important) or lbOwnerDrawVariable if it is.
You can then handle OnDrawItem & OnMeasureItem accordingly.
Using clWindow will be no problem, however AFAIK the orange color is not part of the Windows theme, but you can obtain something that will match the theme by starting from clHighlight and then applying a hue shift, then lightness shift for the shading.
If your hue shift is constant, it'll automatically adapt to the theme colors.
Sample code (without the HueShift for the orange): drop a TListBox, set lbOwnerDrawFixed, adjust ItemHeight to 28, set font to "Segoe UI" and use the following OnDrawItem
var
canvas : TCanvas;
txt : String;
begin
canvas:=ListBox1.Canvas;
canvas.Brush.Style:=bsSolid;
canvas.Brush.Color:=clWindow;
canvas.FillRect(Rect);
InflateRect(Rect, -2, -2);
if odSelected in State then begin
canvas.Pen.Color:=RGB(194, 118, 43);
canvas.Brush.Color:=RGB(255, 228, 138);
canvas.RoundRect(Rect.Left, Rect.Top, Rect.Right, Rect.Bottom, 6, 6);
canvas.Pen.Color:=RGB(246, 200, 103);
canvas.RoundRect(Rect.Left+1, Rect.Top+1, Rect.Right-1, Rect.Bottom-1, 6, 6);
end;
canvas.Font.Color:=clWindowText;
canvas.Brush.Style:=bsClear;
txt:=ListBox1.Items[Index];
Rect.Left:=Rect.Left+10;
canvas.TextRect(Rect, txt, [tfLeft, tfSingleLine, tfVerticalCenter]);
end;
If you're going to have more than one such components, it's of course preferable to just subclass TListBox, and if you want anti-aliasing for the RoundRect, GR32 or GDI+ can be used.
Note that for backward compatibility with XP, "Segoe UI" font should be set dynamically, as it's not available in XP (in XP "Arial" is a good fallback, "Tahoma" looks closer but isn't guaranteed to be there)
We use TMS Control's Advanced Poly Pager for this look. I highly recommend it. It's a very powerful and flexible set of controls. Specifically, we use TAdvPolyList for our Office-style dialogs with some custom tweaking to the colour scheme. (Note this is different to their TAdvOfficePager which doesn't look nearly as good. Don't accidentally mix the two up!)
It allows you to:
Have a category selector on the left
Is a page control, so is easy to have your controls on pages on the right (the same as a normal page control)
Shows a visual link between the tab and page, something the Word screenshot you provided doesn't do (Word has a barrier in-between; this control doesn't. It's a better, more intuitive and well-linked UI deisgn.)
Will certainly allow you to use color constants like clWindow if you wish, though anything would
Has a wide variety of items that can go in the left panel, including images, text with images, links, etc. Your Word screenshot has subtle gray dividing lines separating some of the elements; I'm sure you can do this with this control too, whereas it would be trickier to reliably do with some of the other answers posters have given, such as custom-painting TListBox.
Looks great!
The images on their site don't really show perfectly how to mimic an Office look, but from these two screenshots (high-res on their site) you should be able to see the sort of things you can achieve:
and
Our menus look similar to the second screenshot but with simple text items (nothing complex like checkboxes and images etc - I think they've put those there just to demonstrate that you can) and uses a colour scheme more like yours, plus we added blue headers to each page.
We bought it a couple of years ago and have never regretted it. Highly recommended.
I would have thought you could use two things: a page control for the part on the right.
For the part on the left I'd think you have a few options, the main probably being a GridLayout using 1 column and speed buttons.
Not overly difficult, but a bit messy. You could probably do with a frame to contain the buttons part.
The only difficult bit would be the separation bars, but maybe you could do that by subclassing it and having specific properties.
Regards,
A