1 // SPDX-License-Identifier: GPL-3.0-only
2 unit ULoading;
3 
4 {$mode objfpc}{$H+}
5 
6 interface
7 
8 uses
9   Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
10   ExtCtrls, BCPanel, types, BGRABitmap;
11 
12 type
13 
14   { TFLoading }
15 
16   TFLoading = class(TForm)
17     BGRAPanel1: TBCPanel;
18     Timer1: TTimer;
19     procedure BGRAPanel1AfterRenderBCPanel(Sender: TObject;
20       const ABGRA: TBGRABitmap; {%H-}ARect: TRect);
21     procedure FormCreate(Sender: TObject);
22     procedure Timer1Timer(Sender: TObject);
23     { private declarations }
24   public
25     LoadingStatus: string;
26     WantedTimeOut: integer;
27     { public declarations }
28     procedure SetTimeOut(AMillisecond: integer);
29     procedure ShowMessage(AMessage: string; AMillisecond: integer = 0);
30     procedure HideMessage;
31   end;
32 
33 procedure MessagePopup(AMessage: string; AMillisecond: integer);
34 procedure MessagePopupForever(AMessage: string);
35 procedure MessagePopupHide;
36 
37 implementation
38 
39 uses BGRALayers, BGRAReadLzp, LCScaleDPI, LazPaintType, BGRABitmapTypes;
40 
41 const MarginTopBottom = 3;
42       MarginLeftRight = 3;
43 
44 var PopupWindow: TFLoading;
45     PopupFontFullHeight: integer;
46 
47 procedure MessagePopup(AMessage: string; AMillisecond: integer);
48 begin
49   if AMillisecond <= 0 then AMillisecond:= 1000;
50   if PopupWindow= nil then
51     PopupWindow := TFLoading.Create(nil);
52   PopupWindow.ShowMessage(AMessage, AMillisecond);
53 end;
54 
55 procedure MessagePopupForever(AMessage: string);
56 begin
57   if PopupWindow= nil then
58     PopupWindow := TFLoading.Create(nil);
59   PopupWindow.ShowMessage(AMessage, 0);
60   PopupWindow.SetTimeOut(0);
61 end;
62 
63 procedure MessagePopupHide;
64 begin
65   if PopupWindow <> nil then FreeAndNil(PopupWindow);
66 end;
67 
68 { TFLoading }
69 
70 procedure TFLoading.FormCreate(Sender: TObject);
71 begin
72 end;
73 
74 procedure TFLoading.BGRAPanel1AfterRenderBCPanel(Sender: TObject;
75   const ABGRA: TBGRABitmap; ARect: TRect);
76 begin
77   {$IFDEF LINUX}
78   ABGRA.FontQuality := fqSystemClearType;
79   {$ELSE}
80   ABGRA.FontQuality := fqFineAntialiasing;
81   {$ENDIF}
82   ABGRA.FontFullHeight:= PopupFontFullHeight;
83   ABGRA.TextOut(MarginLeftRight,MarginTopBottom,LoadingStatus,BGRABlack);
84   if WantedTimeOut <> 0 then SetTimeOut(WantedTimeOut);
85 end;
86 
87 procedure TFLoading.Timer1Timer(Sender: TObject);
88 begin
89   Timer1.Enabled:= false;
90   HideMessage;
91 end;
92 
93 procedure TFLoading.ShowMessage(AMessage: string; AMillisecond: integer);
94 var bmp: TBGRABitmap;
95 begin
96   bmp := TBGRABitmap.Create(0,0);
97   {$IFDEF LINUX}
98   bmp.FontQuality := fqSystemClearType;
99   {$ELSE}
100   bmp.FontQuality := fqFineAntialiasing;
101   {$ENDIF}
102   bmp.FontFullHeight:= PopupFontFullHeight;
103   self.LoadingStatus := AMessage;
104   with bmp.TextSize(AMessage) do
105   begin
106     self.ClientWidth := cx+2*MarginLeftRight;
107     self.ClientHeight := cy+2*MarginTopBottom;
108   end;
109   bmp.Free;
110   self.Left := (Screen.Width-self.Width) div 2;
111   self.Top := (Screen.Height-self.Height) div 2;
112   if not self.Visible then self.Show else BGRAPanel1.UpdateControl;
113   if AMillisecond <> 0 then
114     SetTimeOut(AMillisecond);
115   WantedTimeOut := AMillisecond;
116 end;
117 
118 procedure TFLoading.HideMessage;
119 begin
120   if self.Visible then self.Hide;
121   Update;
122 end;
123 
124 procedure TFLoading.SetTimeOut(AMillisecond: integer);
125 begin
126   if AMillisecond = 0 then
127     Timer1.Enabled:= false
128   else
129     begin
130       Timer1.Interval := AMillisecond;
131       Timer1.Enabled := true;
132     end;
133 end;
134 
135 {$R *.lfm}
136 
137 initialization
138   PopupFontFullHeight := DoScaleY(20,OriginalDPI);
139 
140 finalization
141 
142   PopupWindow.Free;
143 
144 end.
145 
146