hintergrundefekt

[turboPASCAL]

Ein Beispiel:

Delphi-Quellcode:

unit Unit1;

interface

uses
  {$IFDEF VER170}
    XPMan,
  {$ENDIF}
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Buttons;

type
  TFadeThread = class(TThread)
  private
    FParameter: Integer;
  protected
    procedure Execute; override;
  public
    constructor Create(FadeLevel: Integer);
  end;

  TForm1 = class(TForm)
    Panel1: TPanel;
    Button1: TButton;
    Panel2: TPanel;
    Panel3: TPanel;
    Panel4: TPanel;
    Panel5: TPanel;
    Panel6: TPanel;
    PaintBox1: TPaintBox;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
  private
    { Private-Deklarationen }
    bmp: TBitmap;
    Fade: TFadeThread;
  public
    { Public-Deklarationen }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

type
  TPixRGBArray = Array [0..2] of Byte;
  PPixRGBArray = ^TPixRGBArray;

procedure ScreenCapture(Bitmap: TBitmap);
var
  c: TCanvas;
  r: TRect;
begin
  c := TCanvas.Create;
  c.Handle := GetWindowDC(GetDesktopWindow);
  try
    r := Rect(0, 0, Screen.Width, Screen.Height);
    Bitmap.Width := Screen.Width;
    Bitmap.Height := Screen.Height;
    Bitmap.Canvas.CopyRect(r, c, r);
  finally
    ReleaseDC(0, c.Handle);
    c.Free;
  end;
end;

procedure MakeGray(Bitmap: TBitmap; HowGray : Byte);
var
  x, y: integer;
  R, G, B, h: Byte;
  Pixel: PPixRGBArray;
begin
  if Bitmap.PixelFormat <> pf24bit then
    Bitmap.PixelFormat := pf24bit;

  for y := 0 to Bitmap.height - 1 do
  begin
    Pixel := Bitmap.ScanLine[y];
    for x := 0 to Bitmap.Width - 1 do
    begin
      R := Pixel^[2];
      G := Pixel^[0];
      B := Pixel^[1];

      //h := (r+b+g) div 3;
      h:= HiByte(r * 77 + g * 150 + b * 28);

      Pixel^[2] := h + Round((R - h) / 255 * HowGray);
      Pixel^[0] := h + Round((G - h) / 255 * HowGray);
      Pixel^[1] := h + Round((B - h) / 255 * HowGray);

      inc(Pixel);
    end;
  end;
end;

constructor TFadeThread.Create(FadeLevel: Integer);
begin
  inherited Create(True);   // Create thread as suspended
  FreeOnTerminate := True;  // Fire and forget
  Priority := tpNormal;     // the priority
  FParameter := FadeLevel;
end;

procedure TFadeThread.Execute;
var
  fa: integer;
begin
  fa := 255;
  while (fa > FParameter) do
  begin
    if not Terminated then Sleep(2) else Break;
    MakeGray(Form1.bmp, fa);
    Form1.PaintBox1.Canvas.Lock;
    Form1.PaintBox1.Canvas.Draw(0, 0, Form1.bmp);
    Form1.PaintBox1.Canvas.Unlock;
    if fa > 0 then dec(fa);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  close;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  bmp := TBitmap.Create;
  ScreenCapture(bmp);

  Width := Screen.DesktopWidth;
  Height := Screen.DesktopHeight;

  Panel1.Left := (ClientRect.Right div 2) - (Panel1.Width div 2);
  Panel1.Top  := (ClientRect.Bottom div 2) - (Panel1.Height div 2);

  Fade := TFadeThread.Create(196);
  Fade.Resume;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  bmp.free;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  PaintBox1.Canvas.Draw(0, 0, bmp);
end;

end.

Warum das "Programm" aber anhält, wenn man es beim faden anklickt ist mir unklar. (Thread ?)