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