326 lines
10 KiB
ObjectPascal
326 lines
10 KiB
ObjectPascal
unit TB2Anim;
|
|
|
|
{$MODE Delphi}
|
|
|
|
{
|
|
Toolbar2000
|
|
Copyright (C) 1998-2008 by Jordan Russell
|
|
All rights reserved.
|
|
|
|
The contents of this file are subject to the "Toolbar2000 License"; you may
|
|
not use or distribute this file except in compliance with the
|
|
"Toolbar2000 License". A copy of the "Toolbar2000 License" may be found in
|
|
TB2k-LICENSE.txt or at:
|
|
http://www.jrsoftware.org/files/tb2k/TB2k-LICENSE.txt
|
|
|
|
Alternatively, the contents of this file may be used under the terms of the
|
|
GNU General Public License (the "GPL"), in which case the provisions of the
|
|
GPL are applicable instead of those in the "Toolbar2000 License". A copy of
|
|
the GPL may be found in GPL-LICENSE.txt or at:
|
|
http://www.jrsoftware.org/files/tb2k/GPL-LICENSE.txt
|
|
If you wish to allow use of your version of this file only under the terms of
|
|
the GPL and not to allow others to use your version of this file under the
|
|
"Toolbar2000 License", indicate your decision by deleting the provisions
|
|
above and replace them with the notice and other provisions required by the
|
|
GPL. If you do not delete the provisions above, a recipient may use your
|
|
version of this file under either the "Toolbar2000 License" or the GPL.
|
|
|
|
$jrsoftware: tb2k/Source/TB2Anim.pas,v 1.13 2008/09/19 16:41:00 jr Exp $
|
|
}
|
|
|
|
interface
|
|
|
|
{$I TB2Ver.inc}
|
|
{$Q-}
|
|
|
|
uses
|
|
LCLIntf, LCLType, LMessages, Messages, SysUtils, Classes;
|
|
|
|
const
|
|
WM_TB2K_ANIMATIONENDED = WM_USER + $556;
|
|
|
|
type
|
|
TTBAnimationDirection = set of (tbadLeft, tbadRight, tbadDown, tbadUp);
|
|
|
|
procedure TBStartAnimation(const AWnd: HWND; const ABlend: Boolean;
|
|
const ADirection: TTBAnimationDirection);
|
|
procedure TBUpdateAnimation;
|
|
procedure TBEndAnimation(const Wnd: HWND);
|
|
function TBIsAnimationInProgress: Boolean;
|
|
|
|
implementation
|
|
|
|
uses
|
|
{$IFDEF CLR} System.Security, System.Runtime.InteropServices, System.Threading, {$ENDIF}
|
|
TB2Common;
|
|
|
|
{ Notes to self:
|
|
- It originally had the NOMIRRORBITMAP flag on the BitBlt calls, because
|
|
Windows 2000's AnimateWindow function has it. But it had to be removed
|
|
because on Windows 98 with the Standard VGA or VMware video driver, it
|
|
caused no bits to be blitted, even though Windows 98 is supposed to
|
|
support NOMIRRORBITMAP according to the documentation. I don't think it's
|
|
necessary anyway.
|
|
}
|
|
|
|
const
|
|
DCX_USESTYLE = $10000;
|
|
WS_EX_LAYERED = $80000;
|
|
NOMIRRORBITMAP = $80000000;
|
|
ULW_ALPHA = 2;
|
|
|
|
type
|
|
PAnimateThreadFuncData = ^TAnimateThreadFuncData;
|
|
TAnimateThreadFuncData = record
|
|
FRunning: Boolean;
|
|
FWnd: HWND;
|
|
FTime: Integer;
|
|
FBlending: Boolean;
|
|
FStartStep, FCurStep: Integer;
|
|
FStartTime, FLastFrameTime: DWORD;
|
|
FWndDC, FBmpDC: HDC;
|
|
FBmp: HBITMAP;
|
|
FScreenClientRect: TRect;
|
|
FSize: TSize;
|
|
FLastPos: TPoint;
|
|
FDirection: TTBAnimationDirection;
|
|
end;
|
|
{ Delphi.NET 2007 note: Because TRect/TSize/TPoint are wrongly declared as
|
|
'packed', fields of these types must be preceded by an Integer- or
|
|
IntPtr-sized field to ensure correct alignment and avoid an alignment
|
|
fault on IA-64. }
|
|
|
|
{$IFNDEF CLR}
|
|
var
|
|
UpdateLayeredWindowProc: function(Handle: HWND; hdcDest: HDC;
|
|
pptDst: PPoint; _psize: PSize; hdcSrc: HDC; pptSrc: PPoint;
|
|
crKey: COLORREF; var pblend: TBLENDFUNCTION; dwFlags: DWORD): BOOL; stdcall;
|
|
{$ELSE}
|
|
{ We can't use Borland.Vcl.Windows' UpdateLayeredWindow because the "pblend"
|
|
parameter is misdeclared (see QC #25130) }
|
|
[SuppressUnmanagedCodeSecurity, DllImport(user32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'UpdateLayeredWindow')]
|
|
function UpdateLayeredWindowProc(Handle: HWND; hdcDest: HDC; const pptDst: TPoint;
|
|
const _psize: TSize; hdcSrc: HDC; const pptSrc: TPoint;
|
|
crKey: COLORREF; [in] var pblend: TBLENDFUNCTION; dwFlags: DWORD): BOOL; overload; external;
|
|
[SuppressUnmanagedCodeSecurity, DllImport(user32, CharSet = CharSet.Ansi, SetLastError = True, EntryPoint = 'UpdateLayeredWindow')]
|
|
function UpdateLayeredWindowProc(Handle: HWND; hdcDest: HDC; pptDst: IntPtr;
|
|
_psize: IntPtr; hdcSrc: HDC; pptSrc: IntPtr;
|
|
crKey: COLORREF; [in] var pblend: TBLENDFUNCTION; dwFlags: DWORD): BOOL; overload; external;
|
|
{$ENDIF}
|
|
|
|
threadvar
|
|
AnimateData: TAnimateThreadFuncData;
|
|
|
|
procedure FinalizeAnimation;
|
|
begin
|
|
{$IFNDEF CLR}
|
|
with PAnimateThreadFuncData(@AnimateData)^ do begin
|
|
{$ELSE}
|
|
with AnimateData do begin
|
|
{$ENDIF}
|
|
FRunning := False;
|
|
if FBmpDC <> 0 then begin
|
|
if FBlending then
|
|
SetWindowLong(FWnd, GWL_EXSTYLE,
|
|
GetWindowLong(FWnd, GWL_EXSTYLE) and not WS_EX_LAYERED)
|
|
else
|
|
SetWindowRgn(FWnd, 0, False);
|
|
BitBlt(FWndDC, 0, 0, FSize.cx, FSize.cy, FBmpDC, 0, 0, SRCCOPY);
|
|
DeleteDC(FBmpDC);
|
|
FBmpDC := 0;
|
|
end;
|
|
if FBmp <> 0 then begin
|
|
DeleteObject(FBmp);
|
|
FBmp := 0;
|
|
end;
|
|
if FWndDC <> 0 then begin
|
|
ReleaseDC(FWnd, FWndDC);
|
|
FWndDC := 0;
|
|
end;
|
|
if FWnd <> 0 then begin
|
|
SendNotifyMessage(FWnd, WM_TB2K_ANIMATIONENDED, 0, 0);
|
|
FWnd := 0;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TBIsAnimationInProgress: Boolean;
|
|
begin
|
|
Result := AnimateData.FRunning;
|
|
end;
|
|
|
|
procedure TBEndAnimation(const Wnd: HWND);
|
|
begin
|
|
if AnimateData.FRunning and
|
|
((Wnd = 0) or (AnimateData.FWnd = Wnd)) then
|
|
FinalizeAnimation;
|
|
end;
|
|
|
|
procedure TBStartAnimation(const AWnd: HWND; const ABlend: Boolean;
|
|
const ADirection: TTBAnimationDirection);
|
|
var
|
|
ZeroPt: TPoint;
|
|
R: TRect;
|
|
Blend: TBlendFunction;
|
|
Rgn: HRGN;
|
|
begin
|
|
FinalizeAnimation;
|
|
|
|
ZeroPt.X := 0;
|
|
ZeroPt.Y := 0;
|
|
|
|
try
|
|
{$IFNDEF CLR}
|
|
{ Note: The pointer cast avoids GetTls calls for every field access }
|
|
with PAnimateThreadFuncData(@AnimateData)^ do begin
|
|
{$ELSE}
|
|
with AnimateData do begin
|
|
{$ENDIF}
|
|
FWnd := AWnd;
|
|
FBlending := ABlend and {$IFNDEF CLR} Assigned(UpdateLayeredWindowProc)
|
|
{$ELSE} (Win32MajorVersion >= 5) {$ENDIF};
|
|
FDirection := ADirection;
|
|
GetCursorPos(FLastPos);
|
|
GetClientRect(FWnd, FScreenClientRect);
|
|
MapWindowPoints(FWnd, 0, FScreenClientRect, 2);
|
|
GetWindowRect(FWnd, R);
|
|
FWndDC := GetDCEx(FWnd, 0, DCX_WINDOW or DCX_CACHE {or DCX_USESTYLE ?});
|
|
if FWndDC = 0 then
|
|
RaiseLastOSError;
|
|
FSize.cx := R.Right - R.Left;
|
|
FSize.cy := R.Bottom - R.Top;
|
|
FBmp := CreateCompatibleBitmap(FWndDC, FSize.cx, FSize.cy {or $01000000 ?});
|
|
if FBmp = 0 then
|
|
RaiseLastOSError;
|
|
FBmpDC := CreateCompatibleDC(FWndDC);
|
|
if FBmpDC = 0 then
|
|
RaiseLastOSError;
|
|
// AnimateWindow calls SetLayout, but I'm not sure that we need to.
|
|
//if Assigned(SetLayoutProc) then
|
|
// SetLayoutProc(FBmpDC, 0);
|
|
SelectObject(FBmpDC, FBmp);
|
|
//SetBoundsRect(FBmpDC, nil, DCB_RESET or DCB_ENABLE);
|
|
SendMessage(FWnd, WM_PRINT, WPARAM(FBmpDC), PRF_NONCLIENT or PRF_CLIENT or
|
|
PRF_ERASEBKGND or PRF_CHILDREN);
|
|
//GetBoundsRect
|
|
if FBlending then begin
|
|
SetWindowLong(FWnd, GWL_EXSTYLE, GetWindowLong(FWnd, GWL_EXSTYLE) or WS_EX_LAYERED);
|
|
FTime := 175; { actually more like ~147 because FCurStep starts at 40 }
|
|
FCurStep := 40;
|
|
Blend.BlendOp := AC_SRC_OVER;
|
|
Blend.BlendFlags := 0;
|
|
Blend.SourceConstantAlpha := FCurStep;
|
|
Blend.AlphaFormat := 0;
|
|
Win32Check(UpdateLayeredWindowProc(FWnd, 0, {$IFNDEF CLR}@{$ENDIF} R.TopLeft,
|
|
{$IFNDEF CLR}@{$ENDIF} FSize, FBmpDC, {$IFNDEF CLR}@{$ENDIF} ZeroPt,
|
|
0, Blend, ULW_ALPHA));
|
|
end
|
|
else begin
|
|
FTime := 150;
|
|
FCurStep := 0;
|
|
Rgn := CreateRectRgn(0, 0, 0, 0);
|
|
if not BOOL(SetWindowRgn(FWnd, Rgn, False)) then
|
|
DeleteObject(Rgn); { just in case }
|
|
end;
|
|
FStartStep := FCurStep;
|
|
FStartTime := GetTickCount;
|
|
FLastFrameTime := FStartTime;
|
|
{ These are the same flags AnimateWindow uses. SWP_ASYNCWINDOWPOS is
|
|
needed or else it doesn't "save bits" properly.
|
|
Note: SWP_ASYNCWINDOWPOS seems to have no effect on Windows 95 & NT 4.0,
|
|
so bits behind the window are not saved & restored correctly. }
|
|
SetWindowPos(FWnd, 0, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE or
|
|
SWP_NOZORDER or SWP_NOACTIVATE or SWP_SHOWWINDOW or SWP_NOREDRAW or
|
|
SWP_NOOWNERZORDER or SWP_ASYNCWINDOWPOS);
|
|
FRunning := True;
|
|
end;
|
|
except
|
|
FinalizeAnimation;
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
procedure TBUpdateAnimation;
|
|
var
|
|
ThisFrameTime: DWORD;
|
|
ElapsedTime, NewStep: Integer;
|
|
P: TPoint;
|
|
Blend: TBlendFunction;
|
|
X, Y: Integer;
|
|
Rgn: HRGN;
|
|
begin
|
|
{$IFNDEF CLR}
|
|
with PAnimateThreadFuncData(@AnimateData)^ do begin
|
|
{$ELSE}
|
|
with AnimateData do begin
|
|
{$ENDIF}
|
|
if not FRunning then
|
|
Exit;
|
|
|
|
{ If 10 msec hasn't passed since the last call, exit. We don't want to
|
|
monopolize the CPU. }
|
|
ThisFrameTime := GetTickCount;
|
|
if ThisFrameTime - FLastFrameTime < 10 then
|
|
Exit;
|
|
FLastFrameTime := ThisFrameTime;
|
|
|
|
ElapsedTime := ThisFrameTime - FStartTime;
|
|
if (ElapsedTime < 0) or (ElapsedTime >= FTime) then begin
|
|
FinalizeAnimation;
|
|
Exit;
|
|
end;
|
|
NewStep := FStartStep + ((255 * ElapsedTime) div FTime);
|
|
if (NewStep < 0) or (NewStep >= 255) then begin
|
|
FinalizeAnimation;
|
|
Exit;
|
|
end;
|
|
|
|
GetCursorPos(P);
|
|
if (P.X <> FLastPos.X) or (P.Y <> FLastPos.Y) then begin
|
|
if PtInRect(FScreenClientRect, P) then begin
|
|
FinalizeAnimation;
|
|
Exit;
|
|
end;
|
|
FLastPos := P;
|
|
end;
|
|
|
|
if NewStep > FCurStep then begin
|
|
FCurStep := NewStep;
|
|
if FBlending then begin
|
|
Blend.BlendOp := AC_SRC_OVER;
|
|
Blend.BlendFlags := 0;
|
|
Blend.SourceConstantAlpha := NewStep;
|
|
Blend.AlphaFormat := 0;
|
|
UpdateLayeredWindowProc(FWnd, 0, nil, nil, 0, nil, 0, Blend, ULW_ALPHA);
|
|
end
|
|
else begin
|
|
if tbadDown in FDirection then
|
|
Y := MulDiv(FSize.cy, NewStep, 255) - FSize.cy
|
|
else if tbadUp in FDirection then
|
|
Y := FSize.cy - MulDiv(FSize.cy, NewStep, 255)
|
|
else
|
|
Y := 0;
|
|
if tbadRight in FDirection then
|
|
X := MulDiv(FSize.cx, NewStep, 255) - FSize.cx
|
|
else if tbadLeft in FDirection then
|
|
X := FSize.cx - MulDiv(FSize.cx, NewStep, 255)
|
|
else
|
|
X := 0;
|
|
Rgn := CreateRectRgn(X, Y, X + FSize.cx, Y + FSize.cy);
|
|
if not BOOL(SetWindowRgn(FWnd, Rgn, False)) then
|
|
DeleteObject(Rgn); { just in case }
|
|
BitBlt(FWndDC, X, Y, FSize.cx, FSize.cy, FBmpDC, 0, 0, SRCCOPY);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
{$IFNDEF CLR}
|
|
UpdateLayeredWindowProc := GetProcAddress(GetModuleHandle(user32),
|
|
'UpdateLayeredWindow');
|
|
{$ENDIF}
|
|
finalization
|
|
FinalizeAnimation;
|
|
end.
|