unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, LMDPNGImage, ExtCtrls, StdCtrls, colorbutton,shellapi;
type
TForm2 =
class(TForm)
Label1: TLabel;
Image1: TImage;
Timer1: TTimer;
Timer2: TTimer;
Label2: TLabel;
Timer3: TTimer;
function SetWndRegionFromImg(Bmp: TBitmap; TransparentColor: TColor): Boolean;
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure Timer3Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
uses Unit1;
{$R *.dfm}
function TForm2.SetWndRegionFromImg(Bmp: TBitmap; TransparentColor: TColor): Boolean;
type
TTransColState = (trsOn, trsOff);
TRGBQuadArray =
array[WORD]
of Cardinal;
pRGBQuadArray = ^TRGBQuadArray;
var
TransColState: TTransColState;
x, y: Integer;
line: Integer;
count: Integer;
rgn, nrgn: THandle;
pPixelArray: pRGBQuadArray;
begin
Result := TRUE;
if Bmp.PixelFormat <> pf32Bit
then
Bmp.PixelFormat := pf32Bit;
count := 0;
line := 0;
rgn := CreateRectRGN(0, 0, 0, 0);
// First Init Region
nrgn := rgn;
for y := 0
to Bmp.Height - 1
do
begin
pPixelArray := Bmp.Scanline[y];
TransColState := trsOff;
for x := 0
to Bmp.Width - 1
do
begin
if pPixelArray[x] <> COLORREF(TransparentColor)
then
begin
if TransColState = trsOff
then
begin
TransColState := trsOn;
line := x - 1;
inc(line);
end;
end else
begin
if TransColState = trsOn
then
begin
TransColState := trsOff;
if count < 4096
then
begin
nrgn := CreateRectRgn(line, y, x, y + 1);
{$IFDEF DEBUGMODE}
bmp.Canvas.Brush.Color := clGreen;
bmp.Canvas.FillRect(RECT(line, y, x, y + 1));
sleep(25);
application.ProcessMessages;
{$ENDIF DEBUGMODE}
CombineRgn(Rgn, Rgn, nRgn, RGN_OR);
inc(Count);
end else
begin
ShowMessage('
Debuginfo: To many Regions. Count of Rgn: '#9 + IntToStr(Count));
Application.Terminate;
end;
end;
end;
{$IFDEF DEBUGMODE}
pPixelArray[x] :=
RGB(random(256), random(256), random(256));
{$ENDIF DEBUGMODE}
end;
end;
SetWindowRgn(
Handle, Rgn, TRUE);
DeleteObject(Rgn);
DeleteObject(nRgn);
end;
procedure TForm2.FormCreate(Sender: TObject);
const
LWA_COLORKEY = 1;
// Use crKey as the transparency color.
LWA_ALPHA = 2;
// Use bAlpha to determine the opacity of the layered window..
WS_EX_LAYERED = $80000;
USER32DLL = '
user32.dll';
var
_SetLayeredWindowAttributes:
function(hWnd: THandle; TRansparentColor: COLORREF;
AlphaValue: Byte; Flags: Cardinal): BOOL;
stdcall;
var
hLib: THandle;
begin
Self.Color := clblack;
Self.BorderStyle := bsNone;
if not (Image1.Picture.Graphic
is TBitmap)
then
begin
ShowMessage('
Fehler: Image muss ein Bitmap sein !');
Application.Terminate;
end;
{$IFDEF DEBUGMODE}
// zum sichtbar machen der Form für den DebugMode
Self.Show;
{$ENDIF DEBUGMODE}
hLib := LoadLibrary(USER32DLL);
@_SetLayeredWindowAttributes := GetProcAddress(hLib, '
SetLayeredWindowAttributes');
if @_SetLayeredWindowAttributes <>
nil then
begin
SetWindowLong(
Handle, GWL_EXSTYLE, GetWindowLong(
Handle, GWL_EXSTYLE)
or WS_EX_LAYERED);
_SetLayeredWindowAttributes(Self.Handle, COLORREF(clblack), 200, LWA_COLORKEY
or LWA_ALPHA);
end
else
begin
// alternative, im falle das es SetLayeredWindowAttributes nicht gibt
SetWndRegionFromImg(Image1.Picture.Bitmap, clblack);
end;
FreeLibrary(hLib);
end;
procedure TForm2.Timer1Timer(Sender: TObject);
begin
Label2.Caption:=inttostr(Timer1.tag)+'
%';
timer1.Enabled:=false;
timer1.Tag:=timer1.Tag+1;
timer1.Enabled:=true;
if Label2.Caption='
0 %'
then label1.caption:='
Lade Programmbibliotheken ...';
if Label2.Caption='
0 %'
then timer1.Interval:= 200;
if Label2.Caption='
11 %'
then label1.caption:='
Lade Umgebungsvariablen ...';
if Label2.Caption='
11 %'
then timer1.interval:= 110;
if Label2.Caption='
27 %'
then label1.caption:='
Lade Laufzeitumgebungen ...';
if Label2.Caption='
27 %'
then timer1.Interval:= 150;
if Label2.Caption='
50 %'
then label1.caption:='
Lade Umgebungsmatrix ...';
if Label2.Caption='
50 %'
then timer1.Interval:=300;
if Label2.Caption='
78 %'
then label1.caption:='
Lade Datenbanksystem ...';
if Label2.Caption='
78 %'
then timer1.Interval:=50;
if Label2.Caption='
92 %'
then label1.caption:='
Lade Vereine ...';
if Label2.Caption='
92 %'
then timer1.Interval:=20;
if Label2.Caption='
100 %'
then timer1.Enabled:=false;
if Label2.Caption='
100 %'
then timer2.enabled:=true;
end;
procedure TForm2.Timer2Timer(Sender: TObject);
begin
Label2.Caption:=inttostr(Timer2.tag)+'
%';
if timer2.Tag = 0
then label1.caption:='
Lade Spielsystem ...';
if Label2.Caption='
0 %'
then timer2.Interval:=200;
timer2.Enabled:=false;
timer2.Tag:=timer2.Tag+1;
timer2.Enabled:=true;
if Label2.Caption='
21 %'
then Label1.Caption:='
Spielerdaten werden gelesen ...';
if Label2.Caption='
21 %'
then timer2.Interval:=20;
if Label2.Caption='
50 %'
then Label1.Caption:='
Spielresourcen werden freigegeben ...';
if Label2.Caption='
50 %'
then timer2.interval:=100;
if Label2.Caption='
76 %'
then Label1.Caption:='
SpielDatenbank wird geoeffnet ...';
if Label2.Caption='
76 %'
then timer2.interval:=35;
if Label2.Caption='
86 %'
then label1.Caption:='
Viel Glueck und Gut Holz !!!';
if Label2.Caption='
86 %'
then timer2.Interval:=1000;
if Label2.Caption='
97 %'
then label1.caption:= '
Programm wird gestartet !!!';
if Label2.Caption='
100 %'
then timer2.Enabled:=false;
if Label2.Caption='
100 %'
then Label2.visible:=false;
if Label2.Caption='
100 %'
then label1.Visible:=false;
if Label2.Caption='
100 %'
then image1.Visible:=false;
if Label2.Caption='
100 %'
then
ShellExecute(Application.Handle,'
open',PChar('
Billiard.exe'),
nil,
nil,sw_ShowNormal);
if Label2.Caption='
100 %'
then close;
end;
procedure TForm2.FormShow(Sender: TObject);
begin
timer3.enabled:=true;
Label1.Caption:='
Lade Programmbibliotheken ...';
Label2.Caption:=inttostr(Timer1.tag)+'
%';
end;
procedure TForm2.Timer3Timer(Sender: TObject);
begin
timer1.Enabled:=true;
timer3.Enabled:=false;
end;
end.