Fade In / Fade Out Forms In Delphi 5

I recently had a need to create a pop up dialog that would show an informational message and close itself after a few seconds without the user having to click a mouse button or press a key on the keyboard. This is easy enough to do by creating a form, placing a timer control on the form and using the OnTimer event to close the window. But I found the abrupt appearance and disappearance of the form to be jarring. How much nicer, I thought, it would be to have the form fade in, linger a while and fade out. It turned out that there was no easy way to do this in Delphi 5, or Delphi 6 for that matter. A little googling turned up an excellent article by Serhiy Perevoznyk that explains how to do it. Here is the code that I used to create a simple fade in, linger and fade out form.


const
WS_EX_LAYERED   = $80000;
LWA_COLORKEY    = 1;
LWA_ALPHA       = 2;
type
TSetLayeredWindowAttributes = function (
hwnd: HWND;
crKey: TColor;
bAlpha: Byte;
dwFlags: DWORD): BOOL; stdcall;
var
SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
procedure TProgressForm.FadeIn(duration: Double);
var
i           : Integer;
sleepTime   : Integer;
begin
sleepTime := Trunc((duration / 25) * 1000);
i := 0;
while (i <= 255) do
begin
SetTransparentForm(i);
Sleep(sleepTime);
Inc(i, 10);
end;
end;

procedure TProgressForm.FadeInMsg(var Message: TMessage);
begin
FadeIn(FFadeDuration);
end;

procedure TProgressForm.FadeOut(duration: Double);
var
i           : Integer;
sleepTime   : Integer;
begin
sleepTime := Trunc((duration / 25) * 1000);
i := 255;
while (i >= 0) do
begin
SetTransparentForm(i);
Sleep(sleepTime);
Dec(i, 10);
end;
end;

procedure TProgressForm.SetCaption(s : String);
begin
ProgressLbl.Caption := s;
Application.ProcessMessages;
end;

procedure TProgressForm.SetTransparentForm(AValue: Byte);
var
osver       : TOSVersionInfo;
begin
FillChar(osver, SizeOf(osver), 0);
osver.dwOSVersionInfoSize := SizeOf(osver);
GetVersionEx(osver);
if ((osver.dwPlatformId = VER_PLATFORM_WIN32_NT) and
(osver.dwmajorVersion >= 5)) then
begin
SetLayeredWindowAttributes := GetProcAddress(GetModuleHandle(user32),
'SetLayeredWindowAttributes');
if (Assigned(SetLayeredWindowAttributes)) then
begin
SetWindowLong(Handle,
GWL_EXSTYLE,
GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_LAYERED);
SetLayeredWindowAttributes(Handle,
0,
AValue,
LWA_ALPHA);
end;
end;
end;

procedure TProgressForm.FormShow(Sender: TObject);
begin
if (FVisibleDuration > 0) then
begin
VisibilityTimer.Interval := FVisibleDuration * 1000;
VisibilityTimer.Enabled := True;
end else
VisibilityTimer.Enabled := False;
if (FFade) then
begin
SetTransparentForm(0);
PostMessage(Handle, FADE_IN_MSG, 0, 0);
end else
SetTransparentForm(100);
end;

procedure TProgressForm.FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
begin
CanClose := True;
VisibilityTimer.Enabled := False;
if (FFade) then
FadeOut(FFadeDuration);
end;

procedure TProgressForm.VisibilityTimerTimer(Sender: TObject);
begin
Close;
end;

Quite a bit of this was stolen directly from the original article so I can’t claim credit, but I thought this might be useful to others.

Leave a Reply