[SOLVED] Bug at TCDWidgetSet.SetTextColor

[lagprogramming]

The file lcl/interfaces/customdrawn/customdrawnwinapi.inc contains the following function:

Code: Pascal  [Select][+][-]

1. function TCDWidgetSet.SetTextColor(DC: HDC; Color: TColorRef): TColorRef;  
2.  
3. The content of the function is:
4. function TCDWidgetSet.SetTextColor(DC: HDC; Color: TColorRef): TColorRef;
5. var
6.   lFont: TFPCustomFont;
7.   LazDC: TLazCanvas;
8. begin
9.   {$ifdef VerboseCDDrawing}
10.     DebugLn(Format('[TCDWidgetSet.SetTextColor]  DC: %x Color: %8x', [DC, Color]));
11.   {$endif}
12.  
13.   Result := CLR_INVALID;
14.   if not IsValidDC(DC) then Exit;
15.   LazDC := TLazCanvas(DC);
16.  
17.   if LazDC.Font <> nil then
18.     LazDC.Font.FPColor := TColorToFPColor(Color);
19. end;

This function always returns CLR_INVALID. I think the following code is better.

Code: Pascal  [Select][+][-]

1. function TCDWidgetSet.SetTextColor(DC: HDC; Color: TColorRef): TColorRef;
2. var
3.   lFont: TFPCustomFont;
4.   LazDC: TLazCanvas;
5. begin
6.   {$ifdef VerboseCDDrawing}
7.     DebugLn(Format('[TCDWidgetSet.SetTextColor]  DC: %x Color: %8x', [DC, Color]));
8.   {$endif}
9.  
10.   if IsValidDC(DC) then
11.   begin
12.     LazDC := TLazCanvas(DC);
13.  
14.     if LazDC.Font <> nil then
15.     begin
16.       LazDC.Font.FPColor := TColorToFPColor(Color);
17.       Exit(Color);
18.     end;
19.   end;
20.   Result := CLR_INVALID;
21. end;

Somebody with lcl development experience might be interested in this.

[zeljko]

Result is not good. It should be previous text color setted up via SetTextColor, not current one...

[lagprogramming]

Result is not good. It should be previous text color setted up via SetTextColor, not current one...

Indeed! I've updated the code.

Code: Pascal  [Select][+][-]

1. //Existing code
2. function TCDWidgetSet.SetTextColor(DC: HDC; Color: TColorRef): TColorRef;
3. var
4.   lFont: TFPCustomFont;
5.   LazDC: TLazCanvas;
6. begin
7.   {$ifdef VerboseCDDrawing}
8.     DebugLn(Format('[TCDWidgetSet.SetTextColor]  DC: %x Color: %8x', [DC, Color]));
9.   {$endif}
10.  
11.   Result := CLR_INVALID;
12.   if not IsValidDC(DC) then Exit;
13.   LazDC := TLazCanvas(DC);
14.  
15.   if LazDC.Font <> nil then
16.     LazDC.Font.FPColor := TColorToFPColor(Color);
17. end;
18.  

 

Code: Pascal  [Select][+][-]

1. //Modified code
2. function TCDWidgetSet.SetTextColor(DC: HDC; Color: TColorRef): TColorRef;
3. var
4.   LazDC: TLazCanvas absolute DC;
5. begin
6.   {$ifdef VerboseCDDrawing}
7.     DebugLn(Format('[TCDWidgetSet.SetTextColor]  DC: %x Color: %8x', [DC, Color]));
8.   {$endif}
9.  
10.   Result := CLR_INVALID;
11.   if not IsValidDC(DC) then exit;
12.  
13.   if LazDC.Font <> nil then
14.   begin
15.     Result := FPColorToTColorRef(LazDC.Font.FPColor);
16.     LazDC.Font.FPColor := TColorToFPColor(Color);
17.   end;
18. end;
19.  

Edit: I forgot the "not" at "if not IsValidDC(DC) then exit;"

[lagprogramming]

The modified code returns the previous color if succesful, CLR_INVALID otherwise. This makes the function consistent with the results of similar functions in other interfaces. Also, has been noticed that variable "lFont: TFPCustomFont;" is not used not only in SetTextColor but also in GetTextColor.

Code: Pascal  [Select][+][-]

1. diff --git a/lcl/interfaces/customdrawn/customdrawnwinapi.inc b/lcl/interfaces/customdrawn/customdrawnwinapi.inc
2. index 0a12ac2d82..22fa18341f 100644
3. --- a/lcl/interfaces/customdrawn/customdrawnwinapi.inc
4. +++ b/lcl/interfaces/customdrawn/customdrawnwinapi.inc
5. @@ -3901,7 +3901,6 @@ end;  *)
6.   ------------------------------------------------------------------------------}
7.  function TCDWidgetSet.GetTextColor(DC: HDC) : TColorRef;
8.  var
9. -  lFont: TFPCustomFont;
10.    LazDC: TLazCanvas;
11.  begin
12.    {$ifdef VerboseCDDrawing}
13. @@ -5818,24 +5817,26 @@ end;*)
14.  
15.  {------------------------------------------------------------------------------
16.    Method:  SetTextColor
17. -  Params:  Handle -
18. -  Returns:
19. +  Params:  DC    - Identifies the device context.
20. +           Color - Specifies the color of the text.
21. +  Returns: The previous color if succesful, CLR_INVALID otherwise
22.   ------------------------------------------------------------------------------}
23.  function TCDWidgetSet.SetTextColor(DC: HDC; Color: TColorRef): TColorRef;
24.  var
25. -  lFont: TFPCustomFont;
26. -  LazDC: TLazCanvas;
27. +  LazDC: TLazCanvas absolute DC;
28.  begin
29.    {$ifdef VerboseCDDrawing}
30.      DebugLn(Format('[TCDWidgetSet.SetTextColor]  DC: %x Color: %8x', [DC, Color]));
31.    {$endif}
32.  
33.    Result := CLR_INVALID;
34. -  if not IsValidDC(DC) then Exit;
35. -  LazDC := TLazCanvas(DC);
36. +  if not IsValidDC(DC) then exit;
37.  
38.    if LazDC.Font <> nil then
39. +  begin
40. +    Result := FPColorToTColorRef(LazDC.Font.FPColor);
41.      LazDC.Font.FPColor := TColorToFPColor(Color);
42. +  end;
43.  end;
44.  
45.  (*{------------------------------------------------------------------------------

[Bart]

Please, please, pretty please: I'm begging you: please submit your patches to the bugtracker.

Bart

[lagprogramming]

Please, please, pretty please: I'm begging you: please submit your patches to the bugtracker.

Bart

I know you want what's best for the community but without realizing, instead of motivating me to work better you demotivate me from presenting bugs and patches. 
For now, I don't want to be involved in using the bugtracker. It's complicated to explain.

[Bart]

... but without realizing, instead of motivating me to work better you demotivate me from presenting bugs and patches. 

Whic is certainly not my intention.

For now, I don't want to be involved in using the bugtracker. It's complicated to explain.

Sorry to hear that.
Feel free to explain in a PM.
We might work out a solution or a workaround (e.g. using an intermediate person as a relay to the bugtracker).

Bart

[AlexTP]

Posted to bugtracker:
https://gitlab.com/freepascal.org/lazarus/lazarus/-/issues/40204