unit SplashThread;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses
Windows, Messages, Classes, SysUtils;
type
TSplashThread =
class(TThread)
private
FTitle :
String;
FWnd : HWND;
hStatic : HWND;
hFontText : HWND;
FWndClass : WNDCLASS;
fText :
String;
protected
procedure Execute;
override;
public
constructor Create(
const Title, Text:
String);
reintroduce;
destructor Destroy;
override;
end;
implementation
constructor TSplashThread.Create(
const Title, Text :
String);
begin
inherited Create(False);
freeOnTerminate := True;
FTitle := Title;
fText := Text;
with FWndClass
do
begin
Style := 0;
lpfnWndProc := @DefWindowProc;
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := HInstance;
hIcon := 0;
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := COLOR_WINDOW;
lpszMenuName :=
nil;
lpszClassName := '
TSplashScreen';
end;
end;
destructor tSplashThread.Destroy;
begin
if FWnd <> 0
then
Begin
DestroyWindow(FWnd);
DestroyWindow(hStatic);
DestroyWindow(hFontText);
end;
Windows.UnregisterClass(FWndClass.lpszClassName, FWndClass.hInstance);
inherited;
End;
procedure TSplashThread.Execute;
var
Msg : TMsg;
begin
if Windows.RegisterClass(FWndClass) = 0
then Exit;
FWnd := CreateWindow(FWndClass.lpszClassName,PChar(fTitle), WS_POPUPWINDOW
or WS_VISIBLE, (GetSystemMetrics(SM_CXSCREEN)
div 2)-150,
(GetSystemMetrics(SM_CYSCREEN)
div 2)- 20, 300,40,0,0,hInstance,
nil);
//Create the fonts to use
hFontText := CreateFont(-14,0,0,0,FW_BOLD,0,0,0,DEFAULT_CHARSET,OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS,DEFAULT_QUALITY,VARIABLE_PITCH
or FF_SWISS,'
Tahoma');
//create the static
hStatic:=CreateWindow('
Static',PChar(fText),WS_VISIBLE
or WS_CHILD
or SS_CENTER, 10,10,290,44,FWnd,0,hInstance,
nil);
SendMessage(hStatic,WM_SETFONT,hFontText,0);
if FWnd = 0
then Exit;
while not Terminated
do
begin
while PeekMessage(Msg, 0, 0, 0, PM_REMOVE)
do
begin
if Msg.
Message <> WM_QUIT
then
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;
end;
end;
end.