Fórum Deixar tudo cinza. #356447

[i]unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button2Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

procedure Grayscale(Bitmap: TBitmap);
Procedure FormDC(hWin:THandle; Bitmap:TBitmap);
procedure xPaintToDC(DC:HDC; x,y:Integer; Bitmap:TBitmap);
procedure SiyahBeyazForm( Form: TForm );
procedure yAlphaBlend(Dest, Source:TBitmap; Alpha:Integer );
var
  Form1: TForm1;

implementation

{$R *.dfm}

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;

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;

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;

procedure xPaintToDC(DC:HDC; x,y:Integer; Bitmap:TBitmap);
begin
  With TCanvas.Create do begin
    Handle := DC;
    Draw(x, y, Bitmap);
    Free;
  end;
end;

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ü&351;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&351;i h&305;zland&305;rmak, ortalama h&305;z&305; e&351;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;
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;
  SiyahBeyazForm( Self );
  Timer_ID := SetTimer(Handle, 0, 3000, @MesajTimer);
end;

procedure TForm1.Button2Click(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;
  SiyahBeyazForm( Nil );
  Timer_ID := SetTimer(Handle, 0, 3000, @MesajTimer);
end;
end[/i].

 brush.style := bsClear;
 WindowState := wsMaximized;
 BorderStyle := bsNone;

var x, y : integer;
begin
for y:=0 to height-1 do
for x:=0 to width-1 do
if (x mod 2)=(y mod 2) then canvas.Pixels[x,y]:=clSilver;
end;