(*
example usage:
uses
kzSplashBar;
procedure TForm1.FormCreate(Sender: TObject);
var
sb: TSplashBar;
begin
sb := TSplashBar.Create(Handle, 'example SplashBar Caption', True);
Sleep(5000); // simulate a blocking main thread
sb.Terminate;
end;
*)
unit kzSplashBar;
interface
uses
Winapi.Windows,
Winapi.Messages,
Winapi.CommCtrl, System.Classes
;
type
TSplashBar =
class(System.Classes.TThread)
private
FhDlg: HWND;
FMarqueeSpeed: Integer;
FLabelCaption:
string;
FButtonCaption:
string;
FShowButton: Boolean;
FMarqueeMode: Boolean;
FParentHandle: HWND;
FAborted: Boolean;
FFlash: Boolean;
FForeGround: Boolean;
protected
procedure Execute;
override;
procedure ShowSplashBar;
procedure SetMarqueeSpeed(
const ASpeed: Integer);
procedure SetLabelCaption(
const ACaption:
string);
procedure SetButtonCaption(
const ACaption:
string);
function SetCaption(
const AControlId: Cardinal;
const ACaption:
string): Boolean;
public
constructor Create(
const AParentHandle: HWND;
const ALabelCaption:
string;
const AEnableMarquee: Boolean);
overload;
constructor Create(
const AParentHandle: HWND;
const ALabelCaption:
string;
const AButtonCaption:
string;
const AEnableMarquee: Boolean);
overload;
property MarqueeSpeed: Integer
read FMarqueeSpeed
write SetMarqueeSpeed;
property MarqueeMode: Boolean
read FMarqueeMode;
property LabelCaption:
string read FLabelCaption
write SetLabelCaption;
property ButtonCaption:
string read FButtonCaption
write SetButtonCaption;
property Aborted: Boolean
read FAborted;
property AutoForeGround: Boolean
read FForeGround
write FForeGround;
property AutoFlash: Boolean
read FFlash
write FFlash;
procedure SetProgressBarColor(
const ARed: Byte;
const AGreen: Byte;
const ABlue: Byte);
procedure SetProgressBarBkColor(
const ARed: Byte;
const AGreen: Byte;
const ABlue: Byte);
procedure SetProgressBarRange(
const AMax: Integer);
procedure SetProgressBarPosition(
const APosition: Integer);
procedure SetProgressBarStep;
end;
implementation
// include needed external resource dialog file
{$R *.res}
const
IDD_SMOOTH = 1000;
IDD_MARQUEE = 1001;
IDD_SMOOTHBUTTON = 1010;
IDD_MARQUEEBUTTON = 1011;
IDC_LABEL = 2000;
IDC_PB = 2001;
IDC_BUTTON = 2002;
var
LAborted: Boolean = False;
{ TSplashBar }
constructor TSplashBar.Create(
const AParentHandle: HWND;
const ALabelCaption:
string;
const AEnableMarquee: Boolean);
begin
FShowButton := False;
FLabelCaption := ALabelCaption;
FButtonCaption := '
';
FAborted := False;
LAborted := False;
FFlash := False;
FForeGround := False;
FMarqueeSpeed := 0;
FParentHandle := AParentHandle;
FMarqueeMode := AEnableMarquee;
inherited Create(False);
FreeOnTerminate := True;
end;
constructor TSplashBar.Create(
const AParentHandle: HWND;
const ALabelCaption:
string;
const AButtonCaption:
string;
const AEnableMarquee: Boolean);
begin
FShowButton := True;
FLabelCaption := ALabelCaption;
FButtonCaption := AButtonCaption;
FAborted := False;
LAborted := False;
FFlash := False;
FForeGround := False;
FMarqueeSpeed := 0;
FParentHandle := AParentHandle;
FMarqueeMode := AEnableMarquee;
inherited Create(False);
FreeOnTerminate := True;
end;
procedure TSplashBar.Execute;
var
Msg: TMsg;
begin
ShowSplashBar;
while ((
not Terminated)
and
GetMessage(Msg, FhDlg, 0, 0)))
do
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
FAborted := LAborted;
EndDialog(FhDlg, 0);
if AutoForeGround
then
SetForegroundWindow(FParentHandle);
if AutoFlash
then
FlashWindow(FParentHandle, BOOL(True));
end;
function TSplashBar.SetCaption(
const AControlId: Cardinal;
const ACaption:
string): Boolean;
begin
Result := SetWindowText(
GetDlgItem(FhDlg, AControlId),
PChar(ACaption)
);
end;
procedure TSplashBar.SetMarqueeSpeed(
const ASpeed: Integer);
begin
if (ASpeed >= 0)
then
begin
FMarqueeSpeed := ASpeed;
SendDlgItemMessage(FhDlg, IDC_PB, PBM_SETMARQUEE, 1, FMarqueeSpeed);
end;
end;
procedure TSplashBar.SetProgressBarColor(
const ARed: Byte;
const AGreen: Byte;
const ABlue: Byte);
begin
SendDlgItemMessage(FhDlg, IDC_PB, PBM_SETBARCOLOR, 1,
RGB(ARed, AGreen, AGreen));
end;
procedure TSplashBar.SetProgressBarBkColor(
const ARed: Byte;
const AGreen: Byte;
const ABlue: Byte);
begin
SendMessage(GetDlgItem(FhDlg, IDC_PB), PBM_SETBKCOLOR, 1,
RGB(ARed, AGreen, AGreen));
end;
procedure TSplashBar.SetProgressBarRange(
const AMax: Integer);
begin
SendMessage(GetDlgItem(FhDlg, IDC_PB), PBM_SETRANGE32, 0, AMax);
SendMessage(GetDlgItem(FhDlg, IDC_PB), PBM_SETRANGE, 0, MakeLParam(0, AMax));
SendMessage(GetDlgItem(FhDlg, IDC_PB), PBM_SETSTEP, WPARAM(AMax
div 10), 0);
end;
procedure TSplashBar.SetProgressBarPosition(
const APosition: Integer);
begin
SendMessage(GetDlgItem(FhDlg, IDC_PB), PBM_SETPOS, APosition, 0);
end;
procedure TSplashBar.SetProgressBarStep;
begin
SendMessage(GetDlgItem(FhDlg, IDC_PB), PBM_STEPIT, 0, 0);
end;
procedure TSplashBar.SetLabelCaption(
const ACaption:
String);
begin
FLabelCaption := ACaption;
SetCaption(IDC_LABEL, FLabelCaption);
end;
procedure TSplashBar.SetButtonCaption(
const ACaption:
string);
begin
if FShowButton
then
begin
FButtonCaption := ACaption;
SetCaption(IDC_BUTTON, FButtonCaption);
end;
end;
function DlgFunc(hWin: HWND; uMsg: UINT; wp: WPARAM; lp: LPARAM): bool;
stdcall;
begin
Result := BOOL(False);
case uMsg
of
WM_CREATE:
begin
end;
// WM_CREATE
WM_INITDIALOG:
begin
end;
// WM_INITDIALOG
WM_ACTIVATE:
begin
end;
// WM_ACTIVATE
WM_LBUTTONDOWN:
begin
Result := BOOL(DefWindowProc(hWin, uMsg, wp, lp));
PostMessage(hWin, WM_SYSCOMMAND, $f012, 0);
end;
// WM_LBUTTONDOWN
WM_PAINT, WM_NCPAINT, WM_NCACTIVATE:
begin
InvalidateRect(hWin,
nil, True);
end;
// WM_PAINT, WM_NCPAINT, WM_NCACTIVATE
WM_SIZE:
begin
MoveWindow(hWin, 0, HiWord(lp), LOWORD(lp), HiWord(lp), True);
end;
// WM_SIZE
WM_COMMAND:
// react on controls command, like buttons or checkboxes etc may invoke
begin
case LoWord(wp)
of // what shall happen when a CONTROL_ID triggered WM_COMMAND
IDC_BUTTON:
begin
if (MessageBox(hWin,
PChar(
'
Would you like to cancel operation?'+#13#10#13#10
+'
(keep in mind that current operation may finish first.)'
),
PChar('
Cancel Operation'),
MB_YESNO
or MB_ICONQUESTION
or MB_TOPMOST
or MB_APPLMODAL)
= ID_YES)
then
begin
LAborted := True;
PostQuitMessage(0);
end;
end;
// ID_BUTTON
end;
// case LoWord(wp)
end;
// WM_COMMAND
WM_CLOSE, WM_DESTROY:
begin
end;
// WM_CLOSE, WM_DESTROY
end;
// case uMsg
end;
procedure TSplashBar.ShowSplashBar;
var
hWndFont: HGDIOBJ;
begin
InitCommonControls;
if (
not FShowButton
and FMarqueeMode)
then
FhDlg := CreateDialogParam(HInstance,
MakeIntResource(IDD_MARQUEE),
GetDesktopWindow, @DlgFunc, 0);
if (
not FShowButton
and not FMarqueeMode)
then
FhDlg := CreateDialogParam(HInstance,
MakeIntResource(IDD_SMOOTH),
GetDesktopWindow, @DlgFunc, 0);
if (FShowButton
and FMarqueeMode)
then
FhDlg := CreateDialogParam(HInstance,
MakeIntResource(IDD_MARQUEEBUTTON),
GetDesktopWindow, @DlgFunc, 0);
if (FShowButton
and not FMarqueeMode)
then
FhDlg := CreateDialogParam(HInstance,
MakeIntResource(IDD_SMOOTHBUTTON),
GetDesktopWindow, @DlgFunc, 0);
if (FhDlg <= 0)
then
Exit;
SetLabelCaption(FLabelCaption);
if FShowButton
then
SetButtonCaption(FButtonCaption);
SetMarqueeSpeed(FMarqueeSpeed);
hWndFont := GetStockObject(DEFAULT_GUI_FONT);
if(hWndFont <> 0)
then
SendMessage(FhDlg, WM_SETFONT, hWndFont, LPARAM(True));
end;
end.