Title: Working dialog showing background form
Question: This is an example of how to create a window with a progress bar and show the calling form as a background image with alpha blend, like Windows Vista does when you shutdown the system. This can be extended to create dialogs or any other kind of forms.
Answer:
In this article I will explain how to create a form with a progress
bar and show the calling form as background image using alpha blend.
This kind of effect is done in Windows Vista/7 when the shutting off
dialog is displayed.
Code Sample
procedure TForm1.Button1Click(Sender: TObject);
var
I: Integer;
begin
formloading:=Tformloading.Create(self);
formloading.progress:=0;
formloading.maxValue:=10;
formloading.Execute();
for I := 1 to 10 do
begin
formloading.incProgress;
sleep(1000);
Application.ProcessMessages;
end;
formloading.Free;
end;
The Alpha blend progress form
The form has a panel, a label, a progress bar, and an image that is
aligned at client. This image is used to show in the background the
calling form using alpha blend.
Step 1 Initializing the form
When the form is executed captures a picture, to a TBitmap object, of
the calling form (owner), and uses the same dimensions as its owner.
procedure Tformloading.Execute;
begin
self.Width:=TWinControl(Owner).Width;
self.Height:=TWinControl(Owner).Height;
self.Left:=TWinControl(Owner).Left;
self.Top:=TWinControl(Owner).Top;
progress:=0;
TakeScreenShoot;
Application.ProcessMessages;
Show;
Application.ProcessMessages;
end;
Step 2 Capturing the background
Before calling the Grab method, the TakeScreenShoot procedure tells to
the owner (it should be a form) to show. Also to ensure that the
window is showing and active, sends a message to Windows to show the
form in order to capture the screen shoot.
procedure Tformloading.TakeScreenShoot;
begin
TWinControl(Owner).Show;
ShowWindow(TWinControl(Owner).Handle,SW_SHOW);
Application.ProcessMessages;
SetActiveWindow(TWinControl(Owner).Handle);
Sleep(100);
Application.ProcessMessages;
Grab(ScreenShoot);
The Grab procedure draws the owner form (calling form) into a bitmap,
with the same dimensions as the owner form.
procedure Tformloading.Grab(bm: TBitMap);
var
DestRect, SourceRect: TRect;
h: THandle;
hdcSrc : THandle;
begin
h := TWinControl(Owner).Handle;
try
if h 0 then
begin
hdcSrc := GetWindowDC(h);
GetWindowRect(h, SourceRect);
bm.Width := SourceRect.Right - SourceRect.Left;
bm.Height := SourceRect.Bottom - SourceRect.Top;
DestRect := Rect(0, 0,
SourceRect.Right - SourceRect.Left,
SourceRect.Bottom - SourceRect.Top);
StretchBlt(bm.Canvas.Handle, 0, 0, bm.Width,
bm.Height, hdcSrc, 0, 0,bm.Width,bm.Height,
SRCCOPY);
end;
finally
ReleaseDC(0, hdcSrc);
end;
end;
Step 3 - Appling alpha blend
Then the alpha blend is applied to the bitmap and assigned to the
TImage control to show the picture in screen.
procedure Tformloading.TakeScreenShoot;
begin
.
//Alpha blend
if ((ScreenShoot.Width0) and (ScreenShoot.Height0)) then
begin
for Y := 0 to ScreenShoot.Height - 1 do
begin
SL := ScreenShoot.ScanLine[Y];
for X := 0 to ScreenShoot.Width - 1 do
begin
try
SL[X].rgbtRed := (FTransparency * SL[X].rgbtRed + (100 -
FTransparency) * GetRValue(FTranspColor)) div 100;
SL[X].rgbtGreen := (FTransparency * SL[X].rgbtGreen + (100 -
FTransparency)* GetGValue(FTranspColor)) div 100;
SL[X].rgbtBlue := (FTransparency * SL[X].rgbtBlue + (100 -
FTransparency) * GetBValue(FTranspColor)) div 100;
except
end;
end
end;
Image1.Picture.Assign(ScreenShoot);
The form allows customizing the caption, the alpha blend value, and
the color to use in the alpha blend.
Then from the calling form you should update the progress bar position
using the IncProgress method. When the work is done, from the calling
form you should free this form and it will disappear from the screen.
This form can be extended to create dialogs window, input windows, and
splash windows.
Source code of the alpha blend form
unit uformloading;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
Forms,
Dialogs, StdCtrls, ExtCtrls, Buttons, ComCtrls;
type
Tformloading = class(TForm)
Image1: TImage;
Panel1: TPanel;
ProgressBar1: TProgressBar;
Label1: TLabel;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
FTransparency:integer;
FTranspColor: TColor;
ScreenShoot: TBitmap;
procedure TakeScreenShoot;
procedure setMaxValue(const Value: integer);
procedure setProgress(const Value: integer);
procedure setLabelCaption(const Value: String);
procedure Grab(bm: TBitMap);
public
{ Public declarations }
procedure Execute;
procedure incProgress;
procedure setFullProgress;
procedure onProgress(Sender:TObject);
published
property TranspColor:TColor read FTranspColor write FTranspColor;
property Transparency:Integer read FTransparency write
FTransparency;
property progress:integer write setProgress;
property maxValue:integer write setMaxValue;
property labelCaption:String write setLabelCaption;
end;
var
formloading: Tformloading;
implementation
{$R *.dfm}
type
PRGBArray = ^TRGBArray;
TRGBArray = Array[0..1000000] of TRGBTriple;
procedure Tformloading.FormCreate(Sender: TObject);
begin
FTransparency:=60;
FTranspColor:=clBlack;
ScreenShoot:= TBitmap.Create;
end;
procedure Tformloading.incProgress;
begin
ProgressBar1.Position:=ProgressBar1.Position + 1;
Application.ProcessMessages;
end;
procedure Tformloading.onProgress(Sender: TObject);
begin
incProgress
end;
procedure Tformloading.setFullProgress;
begin
ProgressBar1.Position:=ProgressBar1.Max;
Application.ProcessMessages;
end;
procedure Tformloading.setLabelCaption(const Value: String);
begin
Label1.Caption:=value;
end;
procedure Tformloading.setMaxValue(const Value: integer);
begin
ProgressBar1.Max:=value;
end;
procedure Tformloading.setProgress(const Value: integer);
begin
ProgressBar1.Position:=value;
end;
procedure Tformloading.Grab(bm: TBitMap);
var
DestRect, SourceRect: TRect;
h: THandle;
hdcSrc : THandle;
begin
h := TWinControl(Owner).Handle;
try
if h 0 then
begin
hdcSrc := GetWindowDC(h);
GetWindowRect(h, SourceRect);
bm.Width := SourceRect.Right - SourceRect.Left;
bm.Height := SourceRect.Bottom - SourceRect.Top;
DestRect := Rect(0, 0,
SourceRect.Right - SourceRect.Left,
SourceRect.Bottom - SourceRect.Top);
StretchBlt(bm.Canvas.Handle, 0, 0, bm.Width,
bm.Height, hdcSrc, 0, 0,bm.Width,bm.Height,
SRCCOPY);
end;
finally
ReleaseDC(0, hdcSrc);
end;
end;
procedure Tformloading.TakeScreenShoot;
var
DC: hDC;
ScreenWidth, ScreenHeight: Integer;
SL: PRGBArray;
X, Y: Integer;
begin
ScreenWidth :=self.Width;
ScreenHeight := self.Height;
ScreenShoot.Width := ScreenWidth;
ScreenShoot.Height := ScreenHeight;
ScreenShoot.PixelFormat := pf24bit;
TWinControl(Owner).Show;
ShowWindow(TWinControl(Owner).Handle,SW_SHOW);
Application.ProcessMessages;
SetActiveWindow(TWinControl(Owner).Handle);
Sleep(100);
Application.ProcessMessages;
Grab(ScreenShoot);
if ((ScreenShoot.Width=0) and (ScreenShoot.Height=0)) then
begin
Grab(ScreenShoot);
Sleep(100);
Application.ProcessMessages;
end;
//Alpha blend
if ((ScreenShoot.Width0) and (ScreenShoot.Height0)) then
begin
for Y := 0 to ScreenShoot.Height - 1 do
begin
SL := ScreenShoot.ScanLine[Y];
for X := 0 to ScreenShoot.Width - 1 do
begin
try
SL[X].rgbtRed := (FTransparency * SL[X].rgbtRed + (100 -
FTransparency) * GetRValue(FTranspColor)) div 100;
SL[X].rgbtGreen := (FTransparency * SL[X].rgbtGreen + (100 -
FTransparency)* GetGValue(FTranspColor)) div 100;
SL[X].rgbtBlue := (FTransparency * SL[X].rgbtBlue + (100 -
FTransparency) * GetBValue(FTranspColor)) div 100;
except
end;
end
end;
Image1.Picture.Assign(ScreenShoot);
end;
end;
procedure Tformloading.Execute;
begin
self.Width:=TWinControl(Owner).Width;
self.Height:=TWinControl(Owner).Height;
self.Left:=TWinControl(Owner).Left;
self.Top:=TWinControl(Owner).Top;
progress:=0;
TakeScreenShoot;
Application.ProcessMessages;
Show;
Application.ProcessMessages;
end;
end.