Tl3GradientWaitbar описан тут -
http://18delphi.blogspot.com/2013/05/blog-post_15.html
unit l3AsincMessageWindow;
{* Вывод ассинхронного окна с сообщением в отдельной триаде }
interface
uses
Windows,
Classes,
Graphics,
Messages,
ImgList,
l3GradientWaitbar
;
type
Tl3AsincMessageWindow = class(TThread)
{* Ассинхронное окно с сообщением }
private
// internal variables
f_Handle : HWND;
f_Caption : Il3CString;
f_Canvas : TCanvas;
f_Progress : THandle;
f_IconSize : TSize;
f_IconHandle : HICON;
f_TextRect : TRect;
f_SizeExcludeText : TSize;
f_Waitbar : Tl3GradientWaitbar;
f_Size : TSize;
f_Images : TCustomImageList;
f_ImageIndex : Integer;
f_BottomContext : Integer;
f_WindowOrigin: TPoint;
f_WindowExtent: TSize;
f_ScreenWidth: Longint;
f_WaitTimeout: Cardinal;
f_Attached: Boolean;
f_InPaint: Integer;
private
// property methods
procedure pm_SetCaption(const aValue : Il3CString);
{-}
procedure pm_SetProgress(const Value : THandle);
{-}
private
// internal methods
procedure InitDC;
{-}
procedure UpdateSize;
{-}
procedure InitFont;
{-}
procedure Paint;
{-}
function DrawTextRect : TRect;
{-}
procedure PaintProgress(aInitPaint : Boolean = True);
{-}
function ProgressRect : TRect;
{-}
function BottomContext : Integer;
{-}
procedure RegisterClass;
{* - регистрируем класс окна которое будем создавать. }
procedure CreateWindow;
{* - создаём окно. }
procedure DestroyWindow;
{* - уничтожаем окно. }
procedure Show;
{* - Показ окна. Окно выводится по центру текущей Application.MainForm }
function ContextSpace : Integer;
{-}
function ContextRect : TRect;
{-}
procedure CalcSizeExcludeText;
{-}
procedure CalcTextRect;
{-}
protected
// protected methods
function CalcSize : TSize;
{* - вычисляет размер формы. }
procedure Execute;
override;
{-}
public
// public methods
constructor Create(const aCaption : Il3CString = nil;
aImages : TCustomImageList = nil;
aImageIndex : Integer = -1;
anAttachWnd : THandle = 0;
anInitialWait : Cardinal = 0);
reintroduce;
virtual;
{-}
destructor Destroy;
override;
{-}
public
// properties
property Caption : Il3CString
read f_Caption
write pm_SetCaption;
{-}
property Progress : THandle
read f_Progress
write pm_SetProgress;
{-}
end;//Tl3AsincMessageWindow
procedure ActivateAllAsyncWindows(anActive: Boolean);
implementation
uses
Controls,
Types,
Math,
SysUtils,
Forms,
MultiMon
;
////////////////////////////////////////////////////////////////////////////////
const
cClassName = 'l3AsincMessageWindow';
{* - имя регистрируемого класса. }
cFrameSize = 4;
{* - ширина рамки. }
cSpace = 5;
{* - расстояние между элементами. }
cProgressHeight = 15;
{* - высота прогресс бара. }
////////////////////////////////////////////////////////////////////////////////
var
g_AllAsyncWindows: TThreadList = nil;
function WindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
// Потенциальная дыра при переходе на 64 бита - указатель на Self перепихивается через SetWindowLong (32 бита).
procedure lpDef;
begin
Result := DefWindowProc(hWnd, Msg, wParam, lParam);
end;
var
l_Window: Tl3AsincMessageWindow;
begin
case Msg of
WM_PAINT:
begin
l_Window := Tl3AsincMessageWindow(GetWindowLong(hWnd, GWL_USERDATA));
if Assigned(l_Window) then
l_Window.Paint;
Result := 0;
end;
WM_DESTROY:
begin
PostQuitMessage(0);
Result := 0;
end;
WM_CLOSE:
SetWindowPos(hWnd, 0, 0, 0, 0, 0, SWP_HIDEWINDOW);
else
lpDef;
end;
end;
// Class Tl3AsincMessageWindow
procedure Tl3AsincMessageWindow.InitFont;
begin
Assert(f_Canvas <> nil);
with f_Canvas.Font do
begin
Size := 10;
Charset := RUSSIAN_CHARSET;
end;//with f_Canvas.Font
end;
constructor Tl3AsincMessageWindow.Create(const aCaption : Il3CString = nil;
aImages : TCustomImageList = nil;
aImageIndex : Integer = -1;
anAttachWnd : THandle = 0;
anInitialWait : Cardinal = 0);
var
l_Rect: TRect;
l_Form: TCustomForm;
l_FormHandle: THandle;
l_MonInfo: TMonitorInfo;
begin
inherited Create(True);
Assert(Suspended);
f_InPaint := 0;
f_WaitTimeout := anInitialWait;
f_Attached := (anAttachWnd <> 0);
if f_Attached then
begin
l_FormHandle := anAttachWnd;
if not GetWindowRect(l_FormHandle,l_Rect) then
begin
f_Attached := False;
end//not GetWindowRect(l_FormHandle,l_Rect)
else
with l_Rect do
begin
f_WindowOrigin := Point(Left, Bottom);
f_ScreenWidth := Right - Left;
f_WindowExtent.cx := 0;
f_WindowExtent.cy := 0;
end;//with l_Rect
end;//f_Attached
if not f_Attached then
begin
l_Form := Application.MainForm;
if Assigned(l_Form) then
begin
l_FormHandle := l_Form.Handle;
if not GetWindowRect(l_FormHandle,l_Rect) then
begin
l_FormHandle := 0;
GetWindowRect(Application.Handle,l_Rect);
end;//not GetWindowRect(l_FormHandle,l_Rect)
end//Assigned(l_Form)
else
begin
l_FormHandle := 0;
GetWindowRect(Application.Handle,l_Rect);
end;//Assigned(l_Form)
f_WindowOrigin := l_Rect.TopLeft;
l_MonInfo.cbSize := SizeOf(l_MonInfo);
GetMonitorInfo(MonitorFromPoint(f_WindowOrigin,MONITOR_DEFAULTTONEAREST), @l_MonInfo);
with l_MonInfo.rcWork do
f_ScreenWidth := Right - Left;
if (l_FormHandle = 0) then
begin
f_WindowOrigin := l_MonInfo.rcWork.TopLeft;
f_WindowExtent.cx := f_ScreenWidth;
with l_MonInfo.rcWork do
f_WindowExtent.cy := Bottom - Top;
end//l_FormHandle = 0
else
with l_Rect do
begin
f_WindowExtent.cx := Right - Left;
f_WindowExtent.cy := Bottom - Top;
end;//with l_Rect
end;//not f_Attached
f_Canvas := TCanvas.Create;
// Waitbar
f_Waitbar := Tl3GradientWaitbar.Create;
if not f_Attached then
begin
// Получим иконку
if Assigned(aImages) and (aImageIndex <> -1) and ((aImageIndex >= 0) and
(aImageIndex < aImages.Count)) then
begin
f_Images := aImages;
f_ImageIndex := aImageIndex;
f_IconSize.cx := aImages.Width;
f_IconSize.cy := aImages.Height;
end//Assigned(aImages)..
else
begin
f_IconSize.cx := GetSystemMetrics(SM_CXICON);
f_IconSize.cy := GetSystemMetrics(SM_CYICON);
f_IconHandle := LoadIcon(0, IDI_EXCLAMATION);
end;//Assigned(aImages)..
end;//not f_Attached
// Размеры без текста
CalcSizeExcludeText;
// Caption
if aCaption <> nil then
Caption := aCaption
else
Caption := str_l3mmLongOperation.AsCStr;
// Размер
f_Size := CalcSize;
// Инициализируем пустым значением
f_BottomContext := -1;
f_Handle := 0;
Resume;
end;
destructor Tl3AsincMessageWindow.Destroy;
// override;
{-}
begin
while (f_InPaint <> 0) do
Sleep(0);
l3Free(f_Canvas);
l3Free(f_Waitbar);
f_Caption := nil;
inherited;
end;
procedure Tl3AsincMessageWindow.CalcTextRect;
begin
SetRectEmpty(f_TextRect);
if not f_Attached then
begin
// Максимальная ширина текста
f_TextRect.Right := f_ScreenWidth div 2 - f_SizeExcludeText.cx;
Assert(f_Canvas <> nil);
// Размер текста
DrawText(f_Canvas.Handle, PAnsiChar(l3Str(f_Caption)), -1, f_TextRect, DT_WORDBREAK or
DT_CALCRECT);
end;//not f_Attached
end;
procedure Tl3AsincMessageWindow.UpdateSize;
begin
if f_Handle <> 0 then
begin
CalcTextRect;
f_Size := CalcSize;
end;
end;
procedure Tl3AsincMessageWindow.pm_SetCaption(const aValue : Il3CString);
{-}
begin
if not l3Same(aValue, f_Caption) then
begin
f_Caption := aValue;
UpdateSize;
end;//not l3Same(aValue, f_Caption)
end;
procedure Tl3AsincMessageWindow.Show;
{* - Показ окна. Окно выводится по центру текущей Application.MainForm }
var
lTop : Integer;
lLeft : Integer;
begin
// Waitbar
Inc(f_InPaint);
try
with ProgressRect do
begin
Assert(f_Waitbar <> nil);
f_Waitbar.SetBounds(0, 0, Right - Left, Bottom - Top);
end;//ProgressRect
f_Waitbar.Speed := 1;
finally
Dec(f_InPaint);
end;//try..finally
// Положение
if f_Attached then
begin
lTop := f_WindowOrigin.y;
lLeft := f_WindowOrigin.x;
end//f_Attached
else
begin
lTop := f_WindowOrigin.y + ((f_WindowExtent.cy div 2) -
(f_Size.cy div 2));
lLeft := f_WindowOrigin.x + ((f_WindowExtent.cx div 2) -
(f_Size.cx div 2));
end;//f_Attached
SetWindowPos(f_Handle, 0, lLeft, lTop, f_Size.cx, f_Size.cy, SWP_SHOWWINDOW or
SWP_NOACTIVATE);
end;
function Tl3AsincMessageWindow.ContextRect : TRect;
begin
if f_Attached then
SetRectEmpty(Result)
else
begin
GetClientRect(f_Handle, Result);
OffsetRect(Result, -Result.Left, -Result.Top);
InflateRect(Result, -ContextSpace, -ContextSpace);
end;
end;
function Tl3AsincMessageWindow.ContextSpace : Integer;
begin
Result := cFrameSize + cSpace;
end;
procedure Tl3AsincMessageWindow.CalcSizeExcludeText;
begin
if not f_Attached then
begin
// От рамки, до компонент
Inc(f_SizeExcludeText.cx, ContextSpace * 2);
Inc(f_SizeExcludeText.cy, ContextSpace * 2);
// Иконка
Inc(f_SizeExcludeText.cx, f_IconSize.cx);
Inc(f_SizeExcludeText.cy, f_IconSize.cy);
// Расстояние до текста
Inc(f_SizeExcludeText.cx, cSpace);
end
else
begin
f_SizeExcludeText.cx := f_ScreenWidth;
f_SizeExcludeText.cy := cFrameSize;
end;
end;
function Tl3AsincMessageWindow.CalcSize : TSize;
begin
Result := f_SizeExcludeText;
// Прогресс
// Рамка
Inc(Result.cy, cFrameSize);
// Прогресс
Inc(Result.cy, cProgressHeight);
// Caption Ширина
Inc(Result.cx, f_TextRect.Right);
// Caption Высота
if f_TextRect.Bottom > f_IconSize.cy then
begin
Dec(Result.cy, f_IconSize.cy);
Inc(Result.cy, f_TextRect.Bottom);
end;
end;
function Tl3AsincMessageWindow.BottomContext : Integer;
begin
// Вычисляем один раз
if f_BottomContext = -1 then
begin
if f_Attached then
f_BottomContext := 0
else
f_BottomContext := ContextSpace + Max(f_IconSize.cy, f_TextRect.Bottom) +
cSpace;
end;
//
Result := f_BottomContext;
end;
function Tl3AsincMessageWindow.ProgressRect : TRect;
begin
Result := Rect(0, 0, f_Size.cx, f_Size.cy);
InflateRect(Result, -cFrameSize, -cFrameSize);
if not f_Attached then
Result.Top := Result.Bottom - cProgressHeight;
InflateRect(Result, -2, -2);
end;
procedure Tl3AsincMessageWindow.PaintProgress(aInitPaint : Boolean = True);
var
lPStruct : TPaintStruct;
begin
Inc(f_InPaint);
try
if (f_Waitbar = nil) or (f_Canvas = nil) then
Exit;
Assert(f_Waitbar <> nil);
f_Waitbar.BackBuf.Canvas.Lock;
try
f_Waitbar.ManualProgress(1);
Assert(f_Waitbar <> nil);
if aInitPaint then
BeginPaint(f_Handle, lPStruct);
try
Assert(f_Canvas <> nil);
with ProgressRect do
BitBlt(f_Canvas.Handle, Left, Top, Right - Left, Bottom - Top,
f_Waitbar.BackBuf.Canvas.Handle, 0, 0, cmSrcCopy);
finally
if aInitPaint then
EndPaint(f_Handle, lPStruct);
end;//try..finally
finally
Assert(f_Waitbar <> nil);
f_Waitbar.BackBuf.Canvas.Unlock;
end;//try..finally
finally
Dec(f_InPaint);
end;//try..finally
end;
function Tl3AsincMessageWindow.DrawTextRect : TRect;
begin
Result.Right := f_Size.cx - ContextSpace;
Result.Left := Result.Right - f_TextRect.Right;
Result.Top := ContextSpace;
Result.Bottom := BottomContext - cSpace;
end;
procedure Tl3AsincMessageWindow.Paint;
{-}
var
lRect : TRect;
lPStruct : TPaintStruct;
lUpdate : Boolean;
lFlags : Integer;
lY : Integer;
begin
Inc(f_InPaint);
try
if (f_Canvas = nil) then
Exit;
lUpdate := GetUpdateRect(f_Handle, lRect, False);
if EqualRect(lRect, ProgressRect) then
begin
PaintProgress;
Exit;
end;//EqualRect(lRect, ProgressRect)
// Область клиентского вывода
GetClientRect(f_Handle, lRect);
// Выводим
if lUpdate then
BeginPaint(f_Handle, lPStruct);
try
// Зальем
Assert(f_Canvas <> nil);
with f_Canvas do
begin
Brush.Color := clBtnFace;
FillRect(lRect);
end;//with f_Canvas
// Внешная рамка
Assert(f_Canvas <> nil);
DrawEdge(f_Canvas.Handle, lRect, BDR_RAISEDINNER, BF_RECT);
if not f_Attached then
begin
// Рамка контекста
InflateRect(lRect, -cFrameSize, -cFrameSize);
lRect.Bottom := BottomContext;
Assert(f_Canvas <> nil);
DrawEdge(f_Canvas.Handle, lRect, BDR_SUNKENINNER, BF_RECT);
end//not f_Attached
else
InflateRect(lRect, -cFrameSize, 0);
// Рамка прогресс бара
lRect.Top := BottomContext + cFrameSize;
lRect.Bottom := lRect.Top + cProgressHeight;
Assert(f_Canvas <> nil);
DrawEdge(f_Canvas.Handle, lRect, BDR_SUNKENINNER, BF_RECT);
if not f_Attached then
begin
// Область вывода
lRect := ContextRect;
// Иконка
lY := ((lRect.Bottom - lRect.Top) - f_IconSize.cy) div 2;
Assert(f_Canvas <> nil);
if Assigned(f_Images) then
f_Images.Draw(f_Canvas, ContextSpace, lY, f_ImageIndex)
else
Windows.DrawIcon(f_Canvas.Handle, ContextSpace, lY, f_IconHandle);
end;//not f_Attached
// Прогресс
PaintProgress(False);
if not f_Attached then
begin
// Caption
if not l3IsNil(f_Caption) then
begin
lRect := DrawTextRect;
if f_IconSize.cy > f_TextRect.Bottom then
begin
lFlags := DT_SINGLELINE or DT_VCENTER;
end
else
lFlags := DT_WORDBREAK;
Assert(f_Canvas <> nil);
Windows.DrawText(f_Canvas.Handle,
PAnsiChar(l3Str(f_Caption)),
-1,
lRect,
lFlags);
end;//if not l3IsNil(f_Caption) then
end;
finally
if lUpdate then
EndPaint(f_Handle, lPStruct);
end;//try..finally
finally
Dec(f_InPaint);
end;//try..finally
end;
procedure Tl3AsincMessageWindow.RegisterClass;
{* - регистрируем класс окна которое будем создавать. }
var
l_Class: TWndClass;
begin
if not GetClassInfo(hInstance, cClassName, l_Class) then
begin
l3FillChar(l_Class, SizeOf(l_Class), 0);
l_Class.style := CS_OWNDC or CS_NOCLOSE or CS_HREDRAW or CS_VREDRAW;
l_Class.lpfnWndProc := @WindowProc;
l_Class.lpszClassName := cClassName;
l_Class.hInstance := hInstance;
Windows.RegisterClass(l_Class);
end;
end;
procedure Tl3AsincMessageWindow.InitDC;
begin
Assert(f_Canvas <> nil);
f_Canvas.Handle := GetDC(f_Handle);
InitFont;
UpdateSize;
end;
procedure Tl3AsincMessageWindow.CreateWindow;
begin
// Зарегистрируем класс
RegisterClass;
// Создадим окно
f_Handle := Windows.CreateWindow(cClassName, '', WS_POPUP,
Integer(CW_USEDEFAULT), 0, Integer(CW_USEDEFAULT), 0, 0, 0, hInstance, nil);
SetWindowLong(f_Handle, GWL_USERDATA, Integer(Self));
if not f_Attached then
begin
SetWindowPos(f_Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
SWP_NOSIZE or SWP_NOACTIVATE);
g_AllAsyncWindows.Add(Pointer(f_Handle));
end;//not f_Attached
// DC
InitDC;
// Покажем окно
Show;
end;
procedure Tl3AsincMessageWindow.DestroyWindow;
begin
if f_Handle = 0 then Exit;
if not f_Attached then
g_AllAsyncWindows.Remove(Pointer(f_Handle));
SetWindowLong(f_Handle, GWL_USERDATA, 0);
SendMessage(f_Handle, WM_PAINT, 0, 0);
Windows.DestroyWindow(f_Handle);
end;
procedure Tl3AsincMessageWindow.Execute;
var
l_Message : TMsg;
l_Rect : TRect;
l_Time : Cardinal;
procedure lpProgress;
const
cDelay = 1;
begin
if (GetTickCount - cDelay >= l_Time) then
begin
l_Rect := ProgressRect;
Inc(f_InPaint);
try
Windows.RedrawWindow(f_Handle, @l_Rect, 0, RDW_INVALIDATE);
finally
Dec(f_InPaint);
end;//try..finally
l_Time := GetTickCount;
end;//GetTickCount - cDelay >= l_Time
end;
begin
while not Terminated and (f_WaitTimeout > 0) do
begin
Sleep(100);
if Terminated then
exit;
if f_WaitTimeout > 100 then
Dec(f_WaitTimeout, 100)
else
begin
Sleep(f_WaitTimeout);
Break;
end;
end;
if Terminated then
exit;
CreateWindow;
try
l_Time := GetTickCount;
repeat
if Terminated then
DestroyWindow;
if PeekMessage(l_Message, 0, 0, 0, PM_REMOVE) then
begin
if (l_Message.Message = WM_QUIT) or
((l_Message.Message = WM_CLOSE) and
(l_Message.hWnd = f_Handle)) then
begin
f_Handle := 0;
Break;
end;
TranslateMessage(l_Message);
DispatchMessage(l_Message);
end;
if not Terminated then
lpProgress;
until False;
finally
DestroyWindow;
end;//try..finally
end;
procedure Tl3AsincMessageWindow.pm_SetProgress(const Value: THandle);
begin
f_Progress := Value;
end;
procedure FinalizeAllAsyncWindows;
begin
FreeAndNil(g_AllAsyncWindows);
end;
procedure ActivateAllAsyncWindows(anActive: Boolean);
var
l_IDX: Integer;
const
cInsertAfter: array [Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST);
begin
with g_AllAsyncWindows.LockList do
try
for l_IDX := Count-1 downto 0 do
SetWindowPos(THandle(Items[l_IDX]), cInsertAfter[anActive], 0, 0, 0, 0, SWP_NOMOVE or
SWP_NOSIZE or SWP_NOACTIVATE);
finally
g_AllAsyncWindows.UnlockList;
end;
end;
initialization
g_AllAsyncWindows := TThreadList.Create;
l3System.AddExitProc(FinalizeAllAsyncWindows);
end.
