- Biliyorsunuz, görmüşsünüzdür WindowsXP shutdown diyaloğunda güzel bir animasyon uygular. Tüm ekran bir süre içerisinde gri tonlamaya bürünür.
- Bunun nasıl yapılacağını ilk o zaman araştırıp uygulamıştım. Şimdi bir soru geldi, onu buradan yayınlama gereği duydum.
- Kodu yayınlamamdaki gaye, bilinmesi gereken ve farklı alanlarda da uygulama alanı olan bu vereceğim iki fonksiyonun ön planda oluşundandır. Bunun için aşağıda beş procedure ile bir button altına bunları hayata geçiren uygulama hazırladık.
- Graphics Device Interface (GDI) komutları ile Device Context (DC) ile geliştirilmiştir. Direkt ekrandan okunur ve ekrana geri basılır. Böylece Form'un başlığı da içine alınmış bir snapshot alınarak gerekli grileştirme yapılır ve sonuç eskisinin üzerine basılır. Buradaki işlem bir ilüzyon ne de olsa
- İnceleyin, geliştirin, kullanın... Afiyet olsun..
Renkli bir Resmi GrayScale (Gri Tonlama) halinde dönüştürme için procedure...Kod: Tümünü seç
procedure Grayscale(Bitmap: TBitmap);
type
pRGBLine = ^TRGBLine;
TRGBLine = Array[word] of TRGBTriple;
pRGBQuadLine = ^TRGBQuadLine;
TRGBQuadLine = Array[word] of TRGBQuad;
var
Line : Pointer;
i, j : Integer;
palCount: Word;
MaxPal : TMaxLogPalette;
pf24 : boolean;
begin
case Bitmap.PixelFormat of
pf1bit, pf4bit, pf8bit: // Palette
begin
// Retrieve the number of palette entries
GetObject(Bitmap.Palette, sizeof(word), @palCount);
MaxPal.palVersion := $0300;
MaxPal.palNumEntries := PalCount;
GetPaletteEntries(Bitmap.Palette, 0, PalCount,
MaxPal.palpalentry);
FOR j := 0 to PalCount - 1 DO
with MaxPal.palPalEntry[j] do
begin
peRed := (peRed + peGreen + peBlue) div 3;
peGreen := peRed;
peBlue := peRed;
end;
Bitmap.Palette := CreatePalette(PLogPalette(@MaxPal)^);
end;
pf15bit, pf16bit:
raise Exception.Create('15bit and 16bit bitmap grayscale conversion not supported');
pf24bit, pf32bit: // 24 bit
begin
pf24 := (Bitmap.PixelFormat = pf24bit);
FOR j := 0 TO Bitmap.Height - 1 DO
begin
Line := Bitmap.Scanline[j];
FOR i := 0 TO Bitmap.Width - 1 DO
if pf24 then
with pRGBLine(Line)[i] do
begin
rgbtRed := (rgbtRed + rgbtGreen + rgbtBlue) div 3;
rgbtgreen := rgbtred;
rgbtblue := rgbtred;
end
else
with pRGBQuadLine(Line)[i] do
begin
rgbRed := (rgbRed + rgbGreen + rgbBlue) div 3;
rgbgreen := rgbred;
rgbblue := rgbred;
end
end;
end;
end;
end;Kod: Tümünü seç
procedure yAlphaBlend(Dest, Source:TBitmap; Alpha:Integer );
var TB :TBLENDFUNCTION;
SRect,
DRect :TRect;
begin
SRect := Source.Canvas.ClipRect;
DRect := Dest.Canvas.ClipRect;
TB.BlendOp := 0;
TB.BlendFlags := 0;
TB.SourceConstantAlpha := alpha;
TB.AlphaFormat:= 0;
Alphablend( Dest.Canvas.Handle, DRect.Left, DRect.Top,
DRect.Right-DRect.Left, DRect.Bottom- DRect.Top,
Source.Canvas.Handle, SRect.Left, SRect.Top,
SRect.Right-SRect.Left, SRect.Bottom- SRect.Top, TB);
end;Kod: Tümünü seç
Procedure FormDC(hWin:THandle; Bitmap:TBitmap);
var
DC, DCWind : HWND;
rc : TRect;
begin
DCWind := hWin;
GetWindowRect(DCWind, rc);
with Bitmap do
try
Width := abs(rc.Right - rc.Left);
Height := abs(rc.Bottom - rc.Top);
DC := GetDC(GetDesktopWindow);
try
BitBlt( Canvas.Handle, 0, 0, Width, Height, DC, rc.Left, rc.Top, SRCCOPY);
finally
ReleaseDC(GetDesktopWindow, DC);
end;
finally
ReleaseDC(hWin, DCWind);
end;
end;
Kod: Tümünü seç
procedure xPaintToDC(DC:HDC; x,y:Integer; Bitmap:TBitmap);
begin
With TCanvas.Create do begin
Handle := DC;
Draw(x, y, Bitmap);
Free;
end;
end;Kod: Tümünü seç
procedure SiyahBeyazForm( Form: TForm );
var
X, Y, Eksiltme : Integer;
Hand : HWND;
Bitmap,
Bitmap1,
Bitmap2 : TBitmap;
Sayac : integer;
DC : HWND;
begin
If Form = Nil then begin
Hand := GetDesktopWindow;
X := 0;
Y := 0;
end else begin
Hand := Form.Handle;
X := Form.Left;
Y := Form.Top;
end;
// Kaynak Bitmap
Bitmap1 := TBitmap.Create;
FormDC( Hand, Bitmap1 );
Bitmap1.PixelFormat := pf24Bit;
// Hedef Bitmap
Bitmap2 := TBitmap.Create;
Bitmap2.Assign( Bitmap1 );
Bitmap2.PixelFormat := pf24Bit;
// GrayScale ( gri tonlamalı ) dönüştürme
Grayscale(Bitmap2);
// AlphaBlend için Bitmap
Bitmap := TBitmap.Create;
Bitmap.PixelFormat := pf24Bit;
// Operasyon Vakti :)
DC := GetDC(0);
Sayac := 0;
// Büyük yüzeylerde işi hızlandırmak, ortalama hızı eşitlemek için
Eksiltme := Bitmap1.Width * Bitmap1.Height div 15000;
While Sayac < 255 do begin
Bitmap.Assign(Bitmap1);
yAlphaBlend( Bitmap, Bitmap2, Sayac );
xPaintToDC( DC, X, Y, Bitmap );
Inc(Sayac, Eksiltme);
end;
ReleaseDC(0, DC);
end;Kod: Tümünü seç
SiyahBeyazForm( Self );
Kod: Tümünü seç
SiyahBeyazForm( Nil );
Bir bonus daha. Ekranı eski haline getiren yani refresh eden kodu da buna eklemek için şöyle bir yöntem buldum. SetTimer ile 3 saniyelik bir bekleme yaptırıp sonucunda ekranı eski haline döndürüyoruz.Kod: Tümünü seç
procedure TForm1.Button1Click(Sender: TObject);
Var Timer_ID:Integer;
procedure MesajTimer;
begin
SystemParametersInfo( SPI_SETDESKWALLPAPER, 0, Nil,
SPIF_SENDWININICHANGE);
KillTimer(Handle, Timer_ID);
end;
begin
Timer_ID := 0;
// 1. Alternatif Sadece Form
SiyahBeyazForm( Self );
// 2. Alternatif Tüm Desktop
// SiyahBeyazForm( Nil );
// Üç saniye sonra eski rengine dönmesini sağlamak için (bu da bonus)...
Timer_ID := SetTimer(Handle, 0, 3000, @MesajTimer);
end;
Düzelttim.