Dimm Form Crossplatform

[KodeZwerg]

While I porting my native windows codelib to crosscompile variants used in freepascal I encountered a small problem with getting correct size of a form and its position on screen.
I came up with this solution but can just test on windows.
I've tested with several screen scale modes (100% - 150% - 175%) and all borderstyles, all worked okay here.

2 Questions:
Is it working on Linux/MacOS same as shown on my attached image?
Is there a better solution to dimm a form when needed?

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

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls;
9.  
10. type
11.  
12.   { TForm1 }
13.  
14.   TForm1 = class(TForm)
15.     Button1: TButton;
16.     procedure Button1Click(Sender: TObject);
17.     procedure FormCreate(Sender: TObject);
18.   strict private
19.     fDimmedForm: TForm;
20.   private
21.     procedure CreateDimmed(const AForm: TForm; const AColor: TColor = clBlack; const AAlphaBlendValue: Integer = 127);
22.     procedure CloseDimmed;
23.   public
24.   end;
25.  
26. var
27.   Form1: TForm1;
28.  
29. implementation
30.  
31. {$R *.lfm}
32.  
33. { TForm1 }
34.  
35. procedure TForm1.CreateDimmed(const AForm: TForm; const AColor: TColor;
36.   const AAlphaBlendValue: Integer);
37.   function DetermineHeight(const AForm: TForm): Integer;
38.   var
39.     global_pos: TPoint;
40.   begin
41.     global_pos := AForm.ClientToScreen(Point(1, 1));
42.     Result := Pred(global_pos.Y) - AForm.Top + AForm.ClientHeight;
43.   end;
44.   function DetermineFormLeft(const AForm: TForm): Integer;
45.   var
46.     global_pos: TPoint;
47.   begin
48.     global_pos := AForm.ClientToScreen(Point(1, 1));
49.     Result := Screen.Monitors[Screen.MonitorFromWindow(Self.Handle, mdNearest).MonitorNum].Left + Pred(global_pos.X);
50.   end;
51. begin
52.   if FDimmedForm <> nil then
53.     CloseDimmed;
54.   FDimmedForm := TForm.CreateNew(nil, 0);
55.   FDimmedForm.AlphaBlend := True;
56.   FDimmedForm.AlphaBlendValue := AAlphaBlendValue;
57.   FDimmedForm.Color := AColor;
58.   FDimmedForm.BorderIcons := [];
59.   FDimmedForm.BorderStyle := bsNone;
60.   FDimmedForm.Top := Succ(AForm.Top);
61.   FDimmedForm.Left := DetermineFormLeft(AForm);
62.   FDimmedForm.Width := AForm.Width;
63.   FDimmedForm.Height := Pred(DetermineHeight(AForm));
64.   FDimmedForm.Visible := True;
65. end;
66.  
67. procedure TForm1.CloseDimmed;
68. begin
69.   FDimmedForm.Free;
70.   FDimmedForm := nil;
71. end;
72.  
73. procedure TForm1.Button1Click(Sender: TObject);
74. begin
75.   CreateDimmed(Self);
76.   with TForm1.Create(nil) do
77.     begin
78.       try
79.         Left := Random(High(Byte));
80.         Top := Random(High(Byte));
81.         ShowModal;
82.       finally
83.         Release;
84.       end;
85.     end;
86.   CloseDimmed;
87. end;
88.  
89. procedure TForm1.FormCreate(Sender: TObject);
90. begin
91.   FDimmedForm := nil;
92. end;
93.  
94. end.

[Handoko]

It doesn't seem to work on Ubuntu Mate using Lazarus 3.0. See the screenshot below.

Similar thing has been discussed here:
https://forum.lazarus.freepascal.org/index.php/topic,42107.msg293272.html#msg293272

[KodeZwerg]

It doesn't seem to work on Ubuntu Mate using Lazarus 3.0. See the screenshot below.

Similar thing has been discussed here:
https://forum.lazarus.freepascal.org/index.php/topic,42107.msg293272.html#msg293272

I do appreciate your test and did read the thread you mentioned. From what I have read and saw, the caption there stay in color of OS and thats not what my aim is.
Also there is nothing mentioned whats the reason for that behave.
Could you be nice and test with this class again and show me the MessageBox please?
(added in a hurry a conditional compiler switch)

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

1. unit kz.forms.dimm;
2.  
3. (*
4. project: dimmed form class
5. author: KodeZwerg
6. copyright: (c) 2024 by KodeZwerg
7. license: Royalty free, the unlicense
8. *)
9.  
10. {$Define Debug}
11.  
12. {$mode ObjFPC}{$H+}
13.  
14. interface
15.  
16. uses
17.   Classes, SysUtils, Forms, Graphics, Controls {$If Defined(Debug)}, Dialogs{$IfEnd};
18.  
19. type
20.  
21.   { TkzDimmedForm }
22.  
23.   TkzDimmedForm = class(TObject)
24.     strict private
25.       FDimmedForm: TForm;
26.     strict private
27.       function FormTop(const AForm: TForm): Integer;
28.       function FormLeft(const AForm: TForm): Integer;
29.       function FormHeight(const AForm: TForm): Integer;
30.     public
31.       constructor Create(const AForm: TForm; const AColor: TColor = clBlack; const AAlphaBlendValue: Integer = 127);
32.       destructor Destroy; override;
33.   end;
34.  
35. implementation
36.  
37. { TkzDimmedForm }
38.  
39. constructor TkzDimmedForm.Create(const AForm: TForm; const AColor: TColor = clBlack; const AAlphaBlendValue: Integer = 127);
40. begin
41.   inherited Create;
42.   FDimmedForm := nil;
43.   if (not Assigned(AForm)) then
44.     raise Exception.Create('TkzDimmedForm - Error, source form not assigned!');
45.   FDimmedForm := TForm.CreateNew(nil, 0);
46.   FDimmedForm.AlphaBlend := True;
47.   FDimmedForm.AlphaBlendValue := AAlphaBlendValue;
48.   FDimmedForm.Color := AColor;
49.   FDimmedForm.BorderIcons := [];
50.   FDimmedForm.BorderStyle := bsNone;
51.   FDimmedForm.Top := FormTop(AForm);
52.   FDimmedForm.Left := FormLeft(AForm);
53.   FDimmedForm.Width := AForm.ClientRect.Width;
54.   FDimmedForm.Height := FormHeight(AForm);
55.   FDimmedForm.Visible := True;
56.   {$If Defined(Debug)}
57.   ShowMessage(Format('Top: %d Left: %d Width: %d Height: %d' + sLineBreak +
58.                      'Top: %d Left: %d Width: %d Height: %d' ,
59.                      [FDimmedForm.Top, FDimmedForm.Left, FDimmedForm.Width, FDimmedForm.Height,
60.                      AForm.Top, AForm.Left, AForm.Width, AForm.Height]));
61.   {$IfEnd}
62. end;
63.  
64. destructor TkzDimmedForm.Destroy;
65. begin
66.   if FDimmedForm <> nil then
67.     begin
68.       FDimmedForm.Free;
69.       FDimmedForm := nil;
70.     end;
71.   inherited Destroy;
72. end;
73.  
74. function TkzDimmedForm.FormHeight(const AForm: TForm): Integer;
75. var
76.   global_pos: TPoint;
77. begin
78.   global_pos := AForm.ClientToScreen(Point(0, 0));
79.   Result := global_pos.Y - Succ(AForm.Top) + AForm.ClientHeight;
80. end;
81.  
82. function TkzDimmedForm.FormTop(const AForm: TForm): Integer;
83. var
84.   global_pos: TPoint;
85. begin
86.   global_pos := AForm.ClientToScreen(Point(0, 0));
87.   Result :=  Screen.Monitors[Screen.MonitorFromWindow(AForm.Handle, mdNearest).MonitorNum].Top + global_pos.Y - (Screen.Monitors[Screen.MonitorFromWindow(AForm.Handle, mdNearest).MonitorNum].Top + (FormHeight(AForm) - AForm.ClientRect.Height));
88. end;
89.  
90. function TkzDimmedForm.FormLeft(const AForm: TForm): Integer;
91. var
92.   global_pos: TPoint;
93. begin
94.   global_pos := AForm.ClientToScreen(Point(0, 0));
95.   Result := Screen.Monitors[Screen.MonitorFromWindow(AForm.Handle, mdNearest).MonitorNum].Left + global_pos.X;
96. end;
97.  
98. end.

example call (uses kz.forms.dimm):

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

1. procedure TForm1.Button1Click(Sender: TObject);
2. var
3.   LDimmed: TkzDimmedForm;
4. begin
5.   try
6.     LDimmed := TkzDimmedForm.Create(Self);
7.     try
8.       with TForm1.Create(nil) do
9.         begin
10.           try
11.             Left := Random(High(Byte));
12.             Top := Random(High(Byte));
13.             ShowModal;
14.           finally
15.             Release;
16.           end;
17.         end;
18.       finally
19.         LDimmed.Free;
20.       end;
21.     except
22.       on E: Exception do
23.         ShowMessage('LDimmed: ' + E.Message);
24.     end;
25. end;

[Handoko]

Tested using Lazarus 3.0 x86_64-linux-gtk2 on Ubuntu Mate 23.10. See the screenshot below.

If any interested to test, you can download the code below.

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

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Classes, Forms, Dialogs, StdCtrls, kz.forms.dimm;
9.  
10. type
11.  
12.   { TForm1 }
13.  
14.   TForm1 = class(TForm)
15.     Button1: TButton;
16.     procedure Button1Click(Sender: TObject);
17.   end;
18.  
19. var
20.   Form1: TForm1;
21.  
22. implementation
23.  
24. {$R *.lfm}
25.  
26. { TForm1 }
27.  
28. procedure TForm1.Button1Click(Sender: TObject);
29. var
30.   LDimmed: TkzDimmedForm;
31. begin
32.   try
33.     LDimmed := TkzDimmedForm.Create(Self);
34.     try
35.       with TForm1.Create(nil) do
36.         begin
37.           try
38.             Left := Random(High(Byte));
39.             Top := Random(High(Byte));
40.             ShowModal;
41.           finally
42.             Release;
43.           end;
44.         end;
45.       finally
46.         LDimmed.Free;
47.       end;
48.     except
49.       ShowMessage('TkzDimmedForm: Error, source form not assigned!');
50.     end;
51. end;
52.  
53. end.

[KodeZwerg]

See the screenshot below.

Thank you very much again for this!
I am unsure how to interprete what I see.
First off all I am happy that my calculated locations does match!
Is now my class making the "original" form pure black?
If so, it is the alphablend feature what is not working on Ubuntu Mate 23.10.
If so, I am shocked and happy to not use Linux (sarcasm) and at same time unable to do anything because I am missing information about Linux API how to test if Alphablending is supported.

[Handoko]

Is now my class making the "original" form pure black?

Yes that test showed a pure black rectangle with white borders.

[KodeZwerg]

Is now my class making the "original" form pure black?

Yes that test showed a pure black rectangle with white borders.

Thanks for clarify!
Like in your mentioned thread I go now the Image way and also asked on Linux category how to test Linux specific APIs.

[TRon]

@kodezwerg:
Alphablending is not possible on linux/GTK. see screenshot.

[cdbc]

Hi
@kodezwerg:
Alphablending is not possible on linux/QT5, just checked...
Regards Benny

[KodeZwerg]

@kodezwerg:
Alphablending is not possible on linux/GTK. see screenshot.

Hi
@kodezwerg:
Alphablending is not possible on linux/QT5, just checked...
Regards Benny

Thank you both!

[KodeZwerg]

I did attached my project, only icon/resource is missing, use any.

Please Linux and MacOs users test it for me because I do have a warning that "ScanLine" is platform specific without telling me what platforms are supported.

Attached is how it does look on windows.

[TRon]

Haven't looked at your code (yet) so behavior might be intended.

Shot1 shows the first startup.
Shot2 is when pressing the button, showing another form exactly as the original form (but at another location) then moving the initial form from it's original location to reveal the dimmed form.

Linux 64bit Bookworm gtk2.

PS: I also noticed this discussion which might or might not be able to provide more background (and makes me wonder about Benny's results).

[KodeZwerg]

Haven't looked at your code (yet) so behavior might be intended.

Shot1 shows the first startup.
Shot2 is when pressing the button, showing another form exactly as the original form (but at another location) then moving the initial form from it's original location to reveal the dimmed form.

Linux 64bit Bookworm gtk2.

PS: I also noticed this discussion which might or might not be able to provide more background (and makes me wonder about Benny's results).

Watching your 2nd image = I fear Linux more and more lol
My code is really not that spacey, just regular things I am doing:
Create a dummy Form over the AForm.
Turn alphablend on for easy doing.
Create an image from the Form Window.
Darken the image.
Apply image to a alClient'ed TImage.

Since on your system the generated Window/Form is under the AForm and not on top... maby a BringToFront helps if Linux support such?
Also I am wondering why the dimmed form look like a rectangle but others having on top rounded corners.
All so confusing lol
And finally, why is the titlebar of the dimmed almost black *cry*

Here's the used code snippet: (const AColor: TColor = clBlack; const AAlphaBlendValue: Integer = 127       <- both are artifact from windows version, will be removed soon)

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

1. constructor TkzDimmedForm.Create(const AForm: TForm; const AColor: TColor = clBlack; const AAlphaBlendValue: Integer = 127);
2.   procedure DimmBitmap(var ABitmap: TBitmap; const ADimLevel: UInt8);
3.   type
4.     TBitmapPixel = record
5.       B, G, R {$IFDEF UNIX}, A {$ENDIF}: UInt8;
6.     end;
7.     PBitmapLine = ^TBitmapLine;
8.     TBitmapLine = array [UInt16] of TBitmapPixel;
9.  
10.   var
11.     Line: PBitmapLine;
12.     LineIndex, PixelIndex: Integer;
13.     LDim: UInt8;
14.   begin
15.     LDim := 255 - ADimLevel;
16.     ABitmap.BeginUpdate();
17.     for LineIndex := 0 to Pred(ABitmap.Height) do
18.     begin
19.       Line := ABitmap.ScanLine[LineIndex];
20.       for PixelIndex := 0 to Pred(ABitmap.Width) do
21.       begin
22.         Line^[PixelIndex].R := Line^[PixelIndex].R * LDim shr 8;
23.         Line^[PixelIndex].G := Line^[PixelIndex].G * LDim shr 8;
24.         Line^[PixelIndex].B := Line^[PixelIndex].B * LDim shr 8;
25.       end;
26.     end;
27.     ABitmap.EndUpdate();
28.   end;
29. var
30.   LFormImage: TBitmap;
31.   LImage: TImage;
32. begin
33.   inherited Create;
34.   FDimmedForm := nil;
35.   if (not Assigned(AForm)) then
36.     raise Exception.Create('TkzDimmedForm - Error, source form not assigned!');
37.   FDimmedForm := TForm.CreateNew(nil, 0);
38.   FDimmedForm.BorderIcons := [];
39.   FDimmedForm.BorderStyle := bsNone;
40.   FDimmedForm.Top := FormTop(AForm);
41.   FDimmedForm.Left := FormLeft(AForm);
42.   FDimmedForm.Width := AForm.ClientRect.Width;
43.   FDimmedForm.Height := FormHeight(AForm);
44.   FDimmedForm.Visible := True;
45.   LImage := TImage.Create(FDimmedForm);
46.   try
47.     LImage.Parent := FDimmedForm;
48.     LImage.Align := alClient;
49.     LImage.Stretch := False;
50.     LFormImage := TBitmap.Create;
51.     try
52.       LFormImage.SetSize(FDimmedForm.Width, FDimmedForm.Height);
53.       LFormImage.PixelFormat := pf24bit;
54.       LFormImage.Canvas.CopyMode := cmSrcCopy;
55.       LFormImage.Canvas.CopyRect(LFormImage.Canvas.ClipRect, AForm.Canvas, Rect(0, AForm.Height - FDimmedForm.Height, FDimmedForm.Width, FDimmedForm.Height + (AForm.Height - FDimmedForm.Height)));
56.       DimmBitmap(LFormImage, 150);
57.       LImage.Picture.Assign(LFormImage);
58.     finally
59.       LFormImage.Free;
60.     end;
61.   finally
62.   end;
63.   {$If Defined(Debug)}
64.   ShowMessage(Format('Top: %d Left: %d Width: %d Height: %d' + sLineBreak +
65.                      'Top: %d Left: %d Width: %d Height: %d' ,
66.                      [FDimmedForm.Top, FDimmedForm.Left, FDimmedForm.Width, FDimmedForm.Height,
67.                      AForm.Top, AForm.Left, AForm.Width, AForm.Height]));
68.   {$IfEnd}
69. end;

[tetrastes]

@kodezwerg:
Alphablending is not possible on linux/GTK. see screenshot.

It is not possible for GTK, but possible for GTK2 (with compositing WM). Note that icons for GTK and GTK2 differ slightly.

[TRon]

It is not possible for GTK, but possible for GTK2 (with compositing WM). Note that icons for GTK and GTK2 differ slightly.

You are correct and I should have added to my comment: out of the box with Lazarus component.

There is software/window manager that is able to apply such fx with gtk2. But as mentioned in the linked discussion: is it worth the effort to implement for gtk2.