I have a tEdit and I want to paint it's rect with a different set of Fill and Stroke colors. I coded as follows:
procedure TForm1.FormCreate (Sender: TObject);
begin
Edit1.OnPaint := HandleEditPaint;
end;
procedure TForm1.HandleEditPaint (Sender: tObject; Canvas: tCanvas; const aRect: tRectF);
begin
Canvas.BeginScene;
Canvas.Fill .Color := TAlphaColorRec.Aqua;
Canvas.Fill .Kind := TBrushKind.bkSolid;
Canvas.Stroke.Color := TAlphaColorRec.Red;
Canvas.Stroke.Kind := TBrushKind.bkSolid;
Canvas.FillRect (aRect, 0, 0, AllCorners, 1, TCornerType.Bevel);
Canvas.DrawRect (aRect, 0, 0, AllCorners, 1, TCornerType.Bevel);
Canvas.EndScene;
end;
It paints the control's rect properly, but it cannot be focused because when clicking on the Control, it enters in a loop that trigger's HandleEditPaint non stop. How can I avoid this to happen? I know that in painting the control's rect, I must take care of the control's text too, but I should concern about the mouse cursor either? Is there a way to achieve this behavior using styles?
Related
I'd like to see emojis in color in a TEdit or TMemo control using VCL and Delphi 10+.
Can it be done?
Text entered:
đ¨đźâđ¤đŠđžâđŠđźâđ§đťâđŚđż
What I see:
What I'd like to see:
Your question made me curious, so tried and here is the result:
Drawing colored fonts in general
Apparently FMX supports this out of the box in later versions, but not in Seattle, which I happen to have. I don't know if the VCL also supports it out of the box in your version, but if not, you can achieve using Direct2D. The trick is to draw text using the D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT option.
In Seattle (10), this constant is not defined, and - unfortunately - not used in the default TCanvas-compatible functions. But you can call DrawText or one of the other functions yourself and specify the option.
The general structure is based on this Embarcadero docwiki. The rest is peeked from TDirect2DCanvas, combined with the DrawText documentation.
uses Vcl.Direct2D, Winapi.D2D1;
{$R *.dfm}
procedure TForm1.FormPaint(Sender: TObject);
const
str: string = 'xyzđ¨đźâđ¤đŠđžâđŠđźâđ§đťâđŚđż';
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT = 4;
var
c: TDirect2DCanvas;
r: D2D_RECT_F;
begin
c := TDirect2DCanvas.Create(Canvas.Handle, Rect(0, 0, 100, 100));
c.BeginDraw;
try
r.left := 0;
r.top := 0;
r.right := 100;
r.bottom := 50;
// Brush determines the font color.
c.Brush.Color := clBlack;
c.RenderTarget.DrawText(
PWideChar(str), Length(Str), c.Font.Handle, r, c.Brush.Handle,
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT);
finally
c.EndDraw;
c.Free;
end;
end;
This little piece of code works in a fairly ugly way (in terms of positioning the text), but you can also peek in TDirect2DCanvas, and copy the implementation of one of its text methods to create a function for outputting text in a specific way that you want. And after that it should be fairly easy to apply this to your own TGraphicControl or TCustomControl descendant to create an emoji-supporting label.
Doing that in TEdit
To manage this in TEdit is harder, since drawing the text (and the emoji) is handled by the control itself. It should be possible to create a TEdit descendant and/or hook into its WM_PAINT message and paint over the text using this same trick, but I'm not sure how well that would work.
I gave that a quick shot, but it doesn't really work well perfectly, especially when editing. So I've made this descendant of TEdit. When focused, it draws the text in a normal way, and the colored emoji will be black and white, and split into two characters (the emoji and the color combination character). When the edit loses its focus, the custom paint code takes over, which works well in that scenario. Maybe you can attempt to polish it to make it work while editing as well, but then you have to take scrolling, positioning the caret and other stuff into account. For a TMemo descendant that would be even harder. I hope you're happy with just colored display for now. :-)
type
TMyEdit = class(Vcl.StdCtrls.TEdit)
protected
procedure PaintWindow(DC: HDC); override;
public
constructor Create(AOwner: TComponent); override;
end;
implementation
uses Vcl.Direct2D, Winapi.D2D1;
{$R *.dfm}
const
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT = 4;
constructor TMyEdit.Create(AOwner: TComponent);
begin
inherited;
DoubleBuffered := True;
end;
procedure TMyEdit.PaintWindow(DC: HDC);
var
c: TDirect2DCanvas;
r: D2D_RECT_F;
begin
// Default drawing when focused. Otherwise do the custom draw.
if Focused then
begin
Inherited;
Exit;
end;
c := TDirect2DCanvas.Create(dc, ClientRect);
c.BeginDraw;
try
r.left := ClientRect.Left;
r.top := ClientRect.Top;
r.right := ClientRect.Right;
r.bottom := ClientRect.Bottom;
// Basic font properties
c.Font.Assign(Font);
// Brush determines the font color.
c.Brush.Color := Font.Color;
c.RenderTarget.DrawText(
PWideChar(Text), Length(Text), c.Font.Handle, r, c.Brush.Handle,
D2D1_DRAW_TEXT_OPTIONS_ENABLE_COLOR_FONT);
finally
c.EndDraw;
c.Free;
end;
end;
I have two TSpeedButton buttons on a form. When one button is enabled, the other is disabled and vice versa. I want to paint the buttons with custom colors to reflect whether they are enabled or disabled.
I coded a procedure named SetButtonsColors. This procedure sets (one button at a time), the variables ButtonFillColor and ButtonStrokeColor with the custom colors, accordingly with the button state, and immediately commands the repainting of the button.
On ButtonPaint handler I set the Canvas.Fill.Color and Canvas.Stroke.Color with ButtonFillColor and ButtonStrokeColor respectively and do the filling and drawing of the aRect.
For my disappointment, the buttons are always painted with the colors set for the last button. This happens, I presume, because Windows paints the buttons asynchronous, and hence, uses the last settings for Canvas.Fill.Color and Canvas.Stroke.Color.
If this is true, how can I force Windows to paint the button immediately after it's repainting is commanded?
Follows the code for SetButtonsColors and ButtonPaint:
procedure tForm1.SetButtonsColors;
begin
if Button1.Enabled then begin
ButtonFillColor := tAlphaColorRec.White;
ButtonStrokeColor := tAlphaColorRec.Black;
Button1.Repaint;
ButtonFillColor := tAlphaColorRec.Black;
ButtonStrokeColor := tAlphaColorRec.White;
Button1.Repaint;
end;
else begin
ButtonFillColor := tAlphaColorRec.Black;
ButtonStrokeColor := tAlphaColorRec.White;
Button1.Repaint;
ButtonFillColor := tAlphaColorRec.White;
ButtonStrokeColor := tAlphaColorRec.Black;
Button2.Repaint;
end;
end;
procedure tForm1.ButtonPaint (Sender: tObject; Canvas: tCanvas; const aRect: tRectF);
begin
Canvas.BeginScene;
Canvas.Fill .Color := lvButtonFillColor;
Canvas.Stroke.Color := lvButtonStrokeColor;
Canvas.FillRect (aRect, 0, 0, [] , 1, CornerTypeBevel);
Canvas.DrawRect (aRect, 0, 0, AllCorners, 1, CornerTypeBevel);
Canvas.EndScene;
end;
Thanks.
I'm stuck in a class derived from TShape.
In the Paint method, I use the Canvas to draw a rectangle. In the Form, I have a TTrackBar that allows to change Left and Top coordinates of the TShape.
It does not matter what values I set to the Left and Top using the TTrackBar, the rectangle does not move accordingly. Instead, when I set those values via code, the rectangle appears in the correct position.
I'm coding a FireMonkey app with Delphi 10.1 Berlin on Windows 10.
unit frmShapeStudy;
interface
type
tMy_Shape = class (tShape)
protected
procedure Paint; override;
public
constructor Create (aOwner: tComponent); override;
procedure Draw;
end;
tformShapeStudy = class (tForm)
trkBarLeft: TTrackBar;
trkBarTop: TTrackBar;
procedure FormCreate (Sender: tObject);
procedure TrackBarChange (Sender: tObject);
end;
var
formShapeStudy: tformShapeStudy;
implementation
{$R *.fmx}
var
My_Shape : tMy_Shape;
lvShapeRect : tRectF ;
procedure tformShapeStudy.FormCreate (Sender: tObject);
begin
My_Shape := tMy_Shape.Create (Self);
with My_Shape do begin
Parent := Self;
TrackBarChange (Self);
end;
end;
procedure tformShapeStudy.TrackBarChange (Sender: TObject);
begin
My_Shape.Draw;
end;
constructor tMy_Shape.Create (aOwner: tComponent);
begin
inherited;
with lvShapeRect do begin
Left := Self.Left;
Top := Self.Top ;
Height := 20;
Width := 20;
end;
end;
procedure tBS_Shape.Draw;
begin
l := formShapeStudy.trkBarLeft.Value;
t := formShapeStudy.trkBarTop .Value;
{`Left & Top` are set with `l & t` or with `120 & 150`
and tested separately, by commenting the propper code lines}
lvShapeRect.Left := l; // this does no work
lvShapeRect.Top := t; // this does no work
lvShapeRect.Left := 120; // this works
lvShapeRect.Top := 150; // this works
Repaint;
end;
procedure tMy_Shape.Paint;
begin
inherited;
with Canvas do begin
Fill .Color := tAlphaColorRec.Aqua;
Stroke.Color := tAlphaColorRec.Blue;
BeginScene;
FillRect (lvShapeRect, 0, 0, Allcorners, 1, tCornerType.Bevel);
DrawRect (lvShapeRect, 0, 0, Allcorners, 1, tCornerType.Bevel);
EndScene;
end;
end;
end.
Sorry Folks! Is the old habit of using Left & Top instead of Position.X & Position.Y. I agree with the new Position way to set Left & Top, but it doesn't make sense that Embarcadero still makes available this properties, but they do nothing in terms of setting Left & Top of the control. Saying it in other words, since those old properties are still available, they should set the Left & Top properties same as Position.X & Position.Y, otherwise it leads to this kind of mistake, where you sware you are setting Left & Top, but the control does not move.
The correct way to set Left & Top is:
Position.X := aLeft;
Position.Y := aTop;
unless Embarcadero changes the behavior of Left & Top properties (wich is very unlikely).
I have an mode that uses TComboBox.SelStart to indicate progress along the edit text string. In this mode I would like to make some kind of change to the edit caret, for example to widen it to 2 pixels or 'bold' it in some way to indicate this mode and to have it grab more attention. Is this possible?
Yes, as Alex mentioned in his comment, this can be done using API calls. Example:
procedure SetComboCaretWidth(ComboBox: TComboBox; Multiplier: Integer);
var
EditWnd: HWND;
EditRect: TRect;
begin
ComboBox.SetFocus;
ComboBox.SelStart := -1;
Assert(ComboBox.Style = csDropDown);
EditWnd := GetWindow(ComboBox.Handle, GW_CHILD);
SendMessage(EditWnd, EM_GETRECT, 0, LPARAM(#EditRect));
CreateCaret(EditWnd, 0,
GetSystemMetrics(SM_CXBORDER) * Multiplier, EditRect.Height);
ShowCaret(EditWnd);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SetComboCaretWidth(ComboBox1, 4); // bold caret
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
SetComboCaretWidth(ComboBox1, 1); // default caret
end;
how do I move a borderless form? I tried looking on the internet, but nothing. Thanks a lot.
You can drag a form using any contained control, including itself.
Using the following example, you can move a form by clicking on its canvas and dragging. You could do the same with a panel on the form by putting the same code in the panel's MouseDown event, which would let you create your own pseudo caption bar.
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DRAGMOVE = $F012;
begin
if Button = mbLeft then
begin
ReleaseCapture;
Perform(WM_SYSCOMMAND, SC_DRAGMOVE, 0);
end;
end;
If you mean dragging the window by the mouse, you can override WM_NCHITTEST message handling and return HTCAPTION for the drag region. The below will drag the window within the upper 30 pixels for insance:
type
TForm1 = class(TForm)
private
protected
procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
end;
..
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
var
Pt: TPoint;
begin
Pt := ScreenToClient(SmallPointToPoint(Message.Pos));
if Pt.Y < 30 then
Message.Result := HTCAPTION
else
inherited;
end;