unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,
PNGImage, GR32, GR32_PNG, PngExtraEx;
type
TForm1 =
class(TForm)
Timer1: TTimer;
PNGBtnEx1: TPNGBtnEx;
PNGBtnEx2: TPNGBtnEx;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormKeyDown(Sender: TObject;
var Key: Word;
Shift: TShiftState);
procedure PNGBtnEx1Click(Sender: TObject);
private
{ Private declarations }
ScrBmp32, PNGBmp32, tmpBmp32: TBitmap32;
BlendF: TBlendFunction;
P: TPoint;
Size: TSize;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{$R ResMenu.RES}
var
BlendValue : Byte = 240;
// Result is TRUE has Pngimage a Alphachannel.
function PNGToBitmap32(DstBitmap: TBitmap32; Png: TPngObject): Boolean;
var
TransparentColor: TColor32;
PixelPtr: PColor32;
AlphaPtr: PByte;
X, Y: Integer;
begin
Result := False;
DstBitmap.Assign(PNG);
DstBitmap.ResetAlpha;
case PNG.TransparencyMode
of
ptmPartial:
begin
if (PNG.Header.ColorType = COLOR_GRAYSCALEALPHA)
or
(PNG.Header.ColorType = COLOR_RGBALPHA)
then
begin
PixelPtr := PColor32(@DstBitmap.Bits[0]);
for Y := 0
to DstBitmap.Height - 1
do
begin
AlphaPtr := PByte(PNG.AlphaScanline[Y]);
for X := 0
to DstBitmap.Width - 1
do
begin
PixelPtr^ := (PixelPtr^
and $00FFFFFF)
or (TColor32(AlphaPtr^)
shl 24);
Inc(PixelPtr);
Inc(AlphaPtr);
end;
end;
end;
Result := True;
end;
ptmBit:
begin
TransparentColor := Color32(PNG.TransparentColor);
PixelPtr := PColor32(@DstBitmap.Bits[0]);
for X := 0
to (DstBitmap.Height - 1) * (DstBitmap.Width - 1)
do
begin
if PixelPtr^ = TransparentColor
then
PixelPtr^ := PixelPtr^
and $00FFFFFF;
Inc(PixelPtr);
end;
Result := True;
end;
ptmNone: Result := False;
end;
end;
procedure ChangeCleartype(Canvas: TCanvas; ClearType: Boolean);
var
lFnt: TLogFont;
Fnt: TFont;
begin
Fnt := TFont.Create;
try
Fnt.Assign(Canvas.Font);
GetObject(Fnt.Handle, sizeof(lFnt), @lFnt);
if ClearType
then lFnt.lfQuality := DEFAULT_QUALITY
else lFnt.lfQuality := NONANTIALIASED_QUALITY;
Fnt.Handle := CreateFontIndirect(lFnt);
Canvas.Font.Assign(Fnt);
finally
Fnt.Free;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
PngImg : TPngObject;
begin
BorderStyle := bsNone;
ScrBmp32 := TBitmap32.Create;
PNGBmp32 := TBitmap32.Create;
tmpBmp32 := TBitmap32.Create;
// Das PNG-Image aus der Resource holen und in ein TBitmap32
// konvertieren.
PngImg := TPngObject.Create;
try
PngImg.LoadFromResourceName(hInstance, '
SMENU');
PNGToBitmap32(PNGBmp32, PngImg);
finally
PngImg.Free;
end;
// Das PNGBitmap32 dem Screen-Bitmap32 zuweisen
ScrBmp32.Assign(PNGBmp32);
// Fenstergrösse anpassen und Position setzen
Width := ScrBmp32.Width;
Height := ScrBmp32.Height;
// Das Fenster mit neuen Parametern ausstatten um Transparenz zu ermöglichen
SetWindowLong(
Handle, GWL_EXSTYLE,
GetWindowLong(
Handle, GWL_EXSTYLE)
or WS_EX_LAYERED
{or WS_EX_TRANSPARENT});
// Fensterblendoptionen festlegen (für UpdateLayeredWindow)
BlendF.BlendOp := AC_SRC_OVER;
BlendF.BlendFlags := 0;
BlendF.SourceConstantAlpha := BlendValue;
BlendF.AlphaFormat := AC_SRC_ALPHA;
P := Point(0, 0);
Size.cx := ScrBmp32.Width;
Size.cy := ScrBmp32.Height;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FreeAndNil(PNGBmp32);
// PNGBmp32.Free;
FreeAndNil(tmpBmp32);
// tmpBmp32.Free;
FreeAndNil(ScrBmp32);
// ScrBmp32.Free;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
bmp : tBitmap;
begin
try
// Png Image auf Bitmap32 "Zeichnen"
ScrBmp32.ResetAlpha;
ScrBmp32.Assign(PNGBmp32);
bmp := GetFormImage;
try
bmp.TransparentColor := clFuchsia;
bmp.Transparent := TRUE;
tmpBmp32.Assign(bmp);
finally
FreeAndNil(bmp);
// bmp.Free;
end;
tmpBmp32.DrawMode := dmBlend;
tmpBmp32.CombineMode := cmBlend;
// Formbitmap auf ScreenBitmap zeichnen
tmpBmp32.DrawTo(ScrBmp32, 0, 0);
// aktualisieren des Fensters mit dem neuen Bitmap.
BlendF.SourceConstantAlpha := BlendValue;
// Blendwert zwischen Desktop und Fenster (0..255)
UpdateLayeredWindow(
Handle, 0,
nil, @Size, ScrBmp32.Handle, @P, 0, @BlendF, ULW_ALPHA);
except
on E:
Exception do
begin
Timer1.Enabled := FALSE;
// Timer aus bei Fehlern, sonst gibt es eine Messageflut...
ShowMessage(E.
Message);
Close;
end;
end;
end;
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if Shift = [ssLeft]
then // Das verschieben der Form auf eine einfache Weise
begin
ReleaseCapture;
Perform(WM_SYSCOMMAND, $F012, 0);
end;
end;
procedure TForm1.FormKeyDown(Sender: TObject;
var Key: Word;
Shift: TShiftState);
begin
if key = vk_escape
then
close;
end;
end.