TButton: change font color

[davornik 4]

I am trying to use TButton, but with changed caption Font.Color. Remy suggested to use BS_OWNERDRAW and intercept WM_DRAWITEM.

and here also to subclass:

 

https://stackoverflow.com/a/23125580

 

I tried it to use like this but no success, font color does not change.

...
type
  TMyButton = class(TButton)
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  end;

function ButtonSubclassProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM; uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall;

var
  btnFntClr: TMyButton;
...

function ButtonSubclassProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM; uIdSubclass: UINT_PTR; dwRefData: DWORD_PTR): LRESULT; stdcall;
begin
  case uMsg of
    WM_DRAWITEM: TMyButton(dwRefData).Font.Color := clRed;
    WM_NCDESTROY: RemoveWindowSubclass(hWnd, @ButtonSubclassProc, uIdSubclass);
  end;
  Result := DefSubclassProc(hWnd, uMsg, wParam, lParam);
end;

procedure TMyButton.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do Style := Style or BS_OWNERDRAW;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  btnFntClr.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  btnFntClr:=TMyButton.Create(Form1);
  btnFntClr.Parent:=Form1;
  btnFntClr.Style:=TCustomButton.TButtonStyle.bsSplitButton;
  btnFntClr.Caption:='Options';
  with btnFntClr do begin
    Left:=10;
    Top:=10;
    Width:=120;
  end;
  SetWindowSubclass(btnFntClr.Handle, @ButtonSubclassProc, 1, DWORD_PTR(btnFntClr));
end;

How to properly change font color in TButton?

[dummzeuch 1622]

You could use TBitBtn instead, if that's an option.

[PeaShooter_OMO 34]

@davornik

 

BS_OWNERDRAW means you must do the drawing of the button yourself. You must also detect user interactions and state changes and respond to them visually.

 

Here is an exmple of such a button (as @Remy Lebeau pointed out on Stack Overflow) :  Delphi - Pascal Windows Color Button

[davornik 4]

On 2/21/2025 at 11:19 AM, dummzeuch said:

You could use TBitBtn instead, if that's an option.

Unfortunatelly, TButton is exactly what I need because TCustomButton.TButtonStyle.bsSplitButton State.

[davornik 4]

On 2/21/2025 at 11:27 AM, PeaShooter_OMO said:

@davornik

 

BS_OWNERDRAW means you must do the drawing of the button yourself. You must also detect user interactions and state changes and respond to them visually.

 

Here is an exmple of such a button (as @Remy Lebeau pointed out on Stack Overflow) :  Delphi - Pascal Windows Color Button

I have seen this example.

Is there any way to just change font color without drawing a complete button?

[PeterBelow 250]

1 hour ago, davornik said:

I have seen this example.

Is there any way to just change font color without drawing a complete button?

Not if you use the standard Windows style. If you configure the app to use one of the custom styles (like Windows 10) you can set the StyleElements.seFont property element to false and it will then use the font.color you set and not the Windows default.

[davornik 4]

What I like about Delphi and Windows is that there is always some way for a workaround 🙂

I have tried to do drawtext over text on TButton and it works partially.

var
  aCaption: string;

procedure DrawColoredTxt(aBtn: TButton);
var
  Canvas: TCanvas;
  R: TRect;
begin
  // Bckp Caption
  if aCaption = '' then
    begin
      aCaption:=aBtn.Caption;
      aBtn.Caption := ''; // Hide default caption to avoid overlap
    end;
  //DoDraw
  Canvas := TCanvas.Create;
  try
    Canvas.Handle := GetDC(aBtn.Handle);
    try
      R := aBtn.ClientRect;
      Inc(R.Left, -15);  //move to left for width of dropsplitbtn
      Canvas.Brush.Style := bsClear;
      Canvas.Font.Color := clRed;  // Change font color
      DrawText(Canvas.Handle, PChar(aCaption), -1, R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
    finally
      ReleaseDC(aBtn.Handle, Canvas.Handle);
    end;
  finally
    Canvas.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DrawColoredTxt(Button2);
end;

I get changed font color like this:

 

 

But when I move the mouse into Button2 everything falls apart 😞

Is there any way to fix this to have properly painted text in Button2?

Edited 16 hours ago by davornik

[Remy Lebeau 1572]

4 hours ago, davornik said:

I have tried to do drawtext over text on TButton and it works partially.

...

I get changed font color like this:

...

But when I move the mouse into Button2 everything falls apart 😞

That is because you are drawing outside of a painting event.  As soon as the button gets repainted for any reason, your drawing is lost.  This is why you must owner-draw the button so that any custom drawing can be persisted across multiple paint events.

[davornik 4]

47 minutes ago, Remy Lebeau said:

That is because you are drawing outside of a painting event.

I have tried to catch OnPaint message, something like this, but no success 😞

...
  procedure DrawColoredTxt(aBtn: TButton; aCaption: string);
private
  procedure WM_PAINT(var Msg: TWMPaint); message WM_PAINT;
...

procedure TForm1.DrawColoredTxt(aBtn: TButton; aCaption: string);
var
  Canvas: TCanvas;
  R: TRect;
begin
  aBtn.Caption := ''; // Clear default caption to avoid overlap
  Canvas := TCanvas.Create;
  try
    Canvas.Handle := GetDC(aBtn.Handle);
    try
      //Draw default button appearance
      SendMessage(aBtn.Handle, WM_ERASEBKGND, Canvas.Handle, 0);
      SendMessage(aBtn.Handle, WM_PRINTCLIENT, Canvas.Handle, PRF_CLIENT);
      // Draw custom text
      R := aBtn.ClientRect;
      Inc(R.Left, -15);  //move to left for width of drop-down-split-btn
      Canvas.Brush.Style := bsClear;
      Canvas.Font.Color := clRed;  // Change font color
      DrawText(Canvas.Handle, PChar(aCaption), -1, R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
    finally
      ReleaseDC(aBtn.Handle, Canvas.Handle);
    end;
  finally
    Canvas.Free;
  end;
end;

//OnPaint Msg
procedure TForm1.WM_PAINT(var Msg: TWMPaint);
begin
  inherited;
  if Assigned(Button2) then DrawColoredTxt(Button2, 'Admin'); //<- this does not work
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DrawColoredTxt(Button2, 'Admin');  //<- this works
end;

What am I missing?

[davornik 4]

Finally, made it work 🙂

...
    procedure DrawColoredTxt(aBtn: TButton; aCaption: string);
  private
    FOriginalButtonProc: LONG_PTR;
    FButtonWndProcInstance: Pointer;
    procedure ButtonWndProc(var Message: TMessage);
...

procedure TForm1.DrawColoredTxt(aBtn: TButton; aCaption: string);
...
end;

procedure TForm1.ButtonWndProc(var Message: TMessage);
var
  PS: TPaintStruct;
begin
  case Message.Msg of
    WM_PAINT: begin
                BeginPaint(Button2.Handle, PS);
                try
                  // 1. Let Windows paint default button
                  CallWindowProc(Pointer(FOriginalButtonProc), Button2.Handle, Message.Msg, Message.WParam, Message.LParam);
                  // 2. Add our custom text
                  DrawColoredTxt(Button2, 'Admin');
                finally
                  EndPaint(Button2.Handle, PS);
                end;
              end;
    // Forward all other messages to original handler
    else Message.Result := CallWindowProc(Pointer(FOriginalButtonProc), Button2.Handle, Message.Msg, Message.wParam, Message.lParam);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  //do OnCreate
  // 1. Create a method pointer instance
  FButtonWndProcInstance := MakeObjectInstance(ButtonWndProc);
  // 2. Store original proc
  FOriginalButtonProc := GetWindowLongPtr(Button2.Handle, GWLP_WNDPROC);
  // 3. Set new proc using the instance
  SetWindowLongPtr(Button2.Handle, GWLP_WNDPROC, LONG_PTR(FButtonWndProcInstance));
  Button2.Repaint;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  //do OnDestroy
  if (Button2.HandleAllocated) and (FOriginalButtonProc <> 0) then SetWindowLongPtr(Button2.Handle, GWLP_WNDPROC, FOriginalButtonProc);
  // Clean up the method pointer
  if Assigned(FButtonWndProcInstance) then FreeObjectInstance(FButtonWndProcInstance);
  Button2.Caption := 'Admin';
  Button2.Repaint;
end;

Literally, I can now set color and clear it 🙂

[Remy Lebeau 1572]

2 hours ago, davornik said:

I have tried to catch OnPaint message, something like this, but no success 😞

You are catching the FORM'S paint event, not the BUTTON'S paint event.  Every window receives its own painting messages (WM_PAINT, WM_DRAWITEM, etc).

1 hour ago, davornik said:

Finally, made it work 🙂

Your code can be simplified a little. If you use the button's WindowProc property, you won't need to call GetWindowLongPtr() directly (and even then, SetWindowSubclass() would have been a better choice). Also, since your DrawColoredTxt() function is completely erasing the button and drawing it yourself, there is no point in calling the default paint handler at all.

 

Try this:

...
    procedure DrawColoredTxt(aBtn: TButton; aCaption: string);
  private
    FOriginalButtonProc: TWndMethod;
    procedure ButtonWndProc(var Message: TMessage);
...

procedure TForm1.DrawColoredTxt(aBtn: TButton; aCaption: string);
begin
  ...
end;

procedure TForm1.ButtonWndProc(var Message: TMessage);
var
  PS: TPaintStruct;
begin
  case Message.Msg of
    WM_PAINT: begin
      BeginPaint(Button2.Handle, PS);
      try
        FOriginalButtonProc(Message);
        DrawColoredTxt(Button2, 'Admin');
      finally
        EndPaint(Button2.Handle, PS);
      end;
    end;
  // Forward all other messages to original handler
  else
    FOriginalButtonProc(Message);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FOriginalButtonProc := Button2.WindowProc;
  Button2.WindowProc := ButtonWndProc;
  Button2.Repaint;
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  if Assigned(FOriginalButtonProc) then
  begin
    Button2.WindowProc := FOriginalButtonProc;
    FOriginalButtonProc := nil;
  end;
  Button2.Caption := 'Admin';
  Button2.Repaint;
end;

But, that being said, since you are drawing the entire button anyway, you may as well just use the BS_OWNERDRAW style and handle the WM_DRAWITEM message, as explained earlier in this discussion thread.