procedure TForm1.Button1Click(Sender: TObject);

   function NuevaRes(XRes, YRes: DWord):integer;
   var
     lpDevMode : TDeviceMode;
   begin
       EnumDisplaySettings(nil, 0, lpDevMode);
       lpDevMode.dmFields:=DM_PELSWIDTH or DM_PELSHEIGHT;
       lpDevMode.dmPelsWidth:=XRes;
       lpDevMode.dmPelsHeight:=YRes;
       NuevaRes:=ChangeDisplaySettings(lpDevMode, 0);
   end;

 begin
   NuevaRes(800,600);
 end;

procedure TForm1.Button1Click(Sender: TObject);
var
  ScreenDC: hDC;
  TmpRect: TRect;
  TmpBitmap: TBitmap;
begin
  ScreenDC := GetDC(0);
  TmpBitmap := TBitmap.Create;
  TmpRect := Rect(0, 0, Screen.Width, Screen.Height);
  TmpBitmap.Width := TmpRect.Right - TmpRect.Left;
  TmpBitmap.Height := TmpRect.Bottom - TmpRect.Top;
  try
    BitBlt(TmpBitmap.Canvas.Handle, TmpRect.Left, TmpRect.Top,
           TmpBitmap.Width, TmpBitmap.Height, ScreenDC, 
           TmpRect.Left, TmpRect.Top, SRCCOPY);
    Image1.Picture.Bitmap.Assign(TmpBitmap);
  finally
    TmpBitmap.Free;
    ReleaseDC(0, ScreenDC);
  end;
end;

uses ClipBrd;

procedure CaptureForm;
var
  Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  Bitmap.Width := ClientWidth;
  Bitmap.Height := ClientHeight;
  try
    with Bitmap.Canvas do
      CopyRect(ClientRect, Canvas, ClientRect);
    Clipboard.Assign(Bitmap);
  finally
    Bitmap.Free;
  end;
end;

var
  bm1,bm2:TBitmap;
const
  links:integer=10; // links u. oben geben die Stelle auf der Form an,
  oben:integer=10;  // an der das Bild erscheint.
  da:boolean=false;

procedure Tform1.zwbmp(faktor:integer);
var
x,y,z:integer;
b1,b2:PByteArray;
begin
if da then exit;
bm1.pixelformat:=pf24bit;
bm2.pixelformat:=pf24bit;
for z:=0 to faktor do begin
for x:=0 to bm1.height-1 do begin
b1:=bm1.scanline[x];
b2:=bm2.scanline[x];
for y:=0 to (bm1.width-1)*3 do
b1[y]:=(b1[y]*(faktor-z)+b2[y])div (faktor-z+1);
end;
canvas.draw(links,oben,bm1);
sleep(2);
end;
da:=true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
bm1:=TBitmap.create;
bm2:=TBitmap.create;
bm2.loadfromfile('c:\bilder\corel009.bmp');
bm1.width:=bm2.width;
bm1.height:=bm2.height;
end;

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

procedure TForm1.Button1Click(Sender: TObject);
begin
bm1.canvas.copyrect(rect(0,0,bm1.width,bm1.height),canvas,
rect(links,oben,links+bm1.width,oben+bm1.width));
zwbmp(50);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
if da then canvas.draw(links,oben,bm1);
end;

procedure TForm1.SetWallpaperPalette;
type
  RGBQUAD = Packed Record
  rgbBlue : Byte;
  rgbGreen : Byte;
  rgbRed : Byte;
  rgbReserved : Byte;
end;
var
  NewColors : Array[1..4] of RGBQUAD;
begin
  FillChar(NewColors,SizeOf(NewColors),0);
  with NewColors[1] do begin
    rgbBlue := 0;
    rgbGreen := $C6;
    rgbRed := $C6;
  end;
  with NewColors[2] do begin
    rgbBlue := 0;
    rgbGreen := $CE;
    rgbRed := $CE;
  end;
  with NewColors[3] do begin
    rgbBlue := 0;
    rgbGreen := $D6;
    rgbRed := $D6;
  end;
  with NewColors[4] do begin
    rgbBlue := 0;
    rgbGreen := $DE;
    rgbRed := $DE;
  end;
  if Assigned(SpeedBar1.Wallpaper.Bitmap) then 
  SetDibColorTable(SpeedBar1.Wallpaper.Bitmap.Canvas.Handle,0,4,NewColors);
end;

procedure TForm1.Button1Click(Sender:TObject);
var x,y:Integer; Bmp:TBitmap;
begin
  bmp:=TBitmap.Create;
  bmp.LoadFromFile('c:\test.bmp');
  for x:=0 to (image1.width div bmp.width) do
    for y:=0 to (image1.height div bmp.height) do
      Image1.Canvas.Draw(x*bmp.width,y*bmp.height,bmp);
  bmp.Free;
end;

var b:TBitmap;

procedure TForm1.FormCreate(Sender: TObject);
begin
  b:=TBitmap.create;
  b.loadfromfile('c:\background.bmp');
  Form1.brush.bitmap:=b;
end;

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

procedure TForm1.FormPaint(Sender: TObject);
var Row,Ht:Word;
    IX:Integer;
begin
  iX:=200;
  Ht:=(ClientHeight + 255) div 256;
  For Row:=0 To 255 Do
  begin
    With Canvas Do
    begin
      Brush.Color:=RGB(Ix,0,row);
      FillRect(Rect(0, Row * Ht, ClientWidth, (Row + 1) * Ht));
      IX:=(IX-1);
    end;
  end;
end;

type
TRGBArray = Array[0..32767] of TRGBTriple;
pRGBArray = ^TRGBArray;

procedure GrayScale(b: TBitmap);
var i, j, Colr: Integer;
sl: pRGBArray; {Scanline}
begin if b.PixelFormat <> pf24bit then begin
ShowMessage( 'not a truecolor bmp' );
Exit; end;
for j := 0 to b.Height - 1 do begin sl := b.ScanLine[j];
for i := 0 to b.Width - 1 do begin
Colr := HiByte(sl[i].rgbtRed * 77 + sl[i].rgbtGreen * 151 + sl[i].rgbtBlue * 28);
sl[i].rgbtRed := Colr; sl[i].rgbtGreen := Colr;
sl[i].rgbtBlue := Colr;
end; end;end;

procedure TForm1.Button1Click(Sender: TObject);
var bmp: TBitmap;
begin
bmp := TBitmap.Create;
bmp.PixelFormat := pf24bit;
bmp.Width := Image1.Picture.Graphic.Width;
bmp.Height := Image1.Picture.Graphic.Height;
bmp.Canvas.Draw(0, 0, Image1.Picture.Graphic);
GrayScale(bmp);
Image1.Picture.Assign(bmp);
bmp.Free;
end;

function CreateGreyScaleBmp(Source: TBitmap): TBitmap;
var Table: array[Byte] of TRGBQuad;
I: Integer;
begin
Result := TBitmap.Create;
with Result do begin PixelFormat := pf8Bit;
Width := Source.Width;
Height := Source.Height;
for I := Low(Table) to High(Table) do with Table[I] do begin
rgbRed := I;
rgbGreen := I;
rgbBlue := I;
rgbReserved := 0; end;
if SetDIBColorTable(Canvas.Handle, Low(Table), High(Table), Table) = 0 then
RaiseLastWin32Error; Canvas.Draw(0, 0, Source); end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  OldBkMode : integer;
begin
  Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
  OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,TRANSPARENT);
  Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
  SetBkMode(Image1.Picture.Bitmap.Canvas.Handle,OldBkMode);
end;

const
da:boolean=false;

procedure EffektText(c:TCanvas;x,y,groesse,winkel:integer;txt,fontname:string;stift,pinsel:TColor;effekt:byte);
var
f,h,lg:integer;
p,b:TColor;
zs:string[1];
begin
p:=c.pen.color;
b:=c.brush.color;
c.pen.color:=stift;
c.brush.color:=pinsel;
h:=c.handle;
f:=CreateFont(groesse,0,winkel*10,winkel*10,FW_HEAVY,
0,0,0,DEFAULT_CHARSET,OUT_TT_PRECIS,$10,default_quality,
default_pitch,pchar(fontname));
if effekt and 1 = 0 then begin
setBkMode(h,TRANSPARENT);
zs:=''; lg:=0;
end else begin
zs:=#32; lg:=2;
end;
selectobject(h,f);
BeginPath(h);
textout(h,x,y,pchar(zs+txt+zs),length(txt)+lg);
EndPath(h);
if effekt and 6 = 2 then strokepath(h) else
if effekt and 6 = 4 then fillpath(h) else
strokeandfillPath(h);
deleteobject(f);
c.pen.color:=p;
c.brush.color:=b;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
if da then
EffektText(canvas,10,275,40,45,'Das ist ein Test-Satz.','Arial',$4500ff,$0099ff,0);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
da:=true;
paint;
end;

procedure TForm1.Image1MouseMove(Sender: TObject);
var P:TPoint;
begin
getcursorpos(p);
p:=screentoclient(p);
label1.caption:=colortostring(canvas.pixels[p.x,p.y]);
end;

private
farb:string;
sl:TStringlist;
bu:TFontname;
gr,l,verl:integer;
un:boolean;
links,rechts:TColor;
protected
procedure setfarb(s:string);
procedure setbu(f:TFontname);
procedure setgr(i:integer);
procedure dazu;
procedure setun(b:boolean);
procedure verlauf;
function wandeln(s:string):TColor;
public
procedure paint;override;
constructor Create(Owner: TComponent); override;
destructor Destroy; override;
published
property Bunt:string read farb write setfarb;
property FontName:TFontname read bu write setbu;
property FontSize:integer read gr write setgr;
property FontUnderline:boolean read un write setun;
property Color;
property Enabled;
property Caption;
property Visible;
property Transparent;
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;

procedure Register;

implementation

constructor TForm1.Create(Owner: TComponent);
begin
inherited Create(Owner);
farb:='1 clblue 5 $0055FF 2 $99FFFF';
sl:=TStringlist.create;
bu:=font.name;
font.size:=15;
gr:=font.size;
sl.commatext:=farb;
dazu;
end;

procedure TForm1.dazu;
begin
if odd(sl.count)then sl.add('0');
sl.add('255');
sl.add('0');
end;

destructor TForm1.Destroy;
begin
sl.free;
inherited Destroy;
end;

procedure TForm1.setbu(f:TFontname);
begin
if f=bu then exit;
bu:=f;
font.name:=bu;
end;

procedure TForm1.setgr(i:integer);
begin
if i=gr then exit;
gr:=i;
font.size:=gr;
end;

function TForm1.wandeln(s:string):TColor;
begin
try
result:=StringToColor(s);
except
result:=$FFFFFF;
end;
end;

procedure TForm1.verlauf;
var x,r1,r2,g1,g2,b1,b2,r,g,b:integer;
begin
r1:=getrvalue(links);
g1:=getgvalue(links);
b1:=getbvalue(links);
r2:=getrvalue(rechts);
g2:=getgvalue(rechts);
b2:=getbvalue(rechts);
r:=(r2-r1)div l;
g:=(g2-g1)div l;
b:=(b2-b1)div l;
with canvas do begin
for x:=1 to (l div verl) do begin
font.color:=rgb(r1,g1,b1);
textout(penpos.x,0,caption[x]);
inc(r1,r*verl);
inc(g1,g*verl);
inc(b1,b*verl);
end;
if verl = 2 then
for x:=(l div 2)+1 to l do begin
font.color:=rgb(r1,g1,b1);
textout(penpos.x,0,caption[x]);
dec(r1,r*2);
dec(g1,g*2);
dec(b1,b*2);
end;
end;
end;

procedure TForm1.Paint;
var x,j,k:integer;
b:byte;
begin
if (not enabled) then inherited
else begin
with canvas do begin
if transparent then brush.style:=bsclear
else begin
brush.color:=color;
brush.style:=bssolid;
end;
if caption <> '' then begin
l:=length(caption);
moveto(0,0);
if verl > 0 then verlauf
else begin
j:=0;k:=1;
repeat
if j < sl.count then
font.color:=wandeln(sl.strings[j+1]);
try
b:=abs(strtoint(sl.strings[j]));
except b:=0;end;
for x:=0 to b-1 do begin
textout(penpos.x,0,caption[x+k]);
if x+k=l then exit;
end;
inc(k,b);
inc(j,2);
until false;
end;
end;
end;
end;
end;

procedure TForm1.setun(b:boolean);
begin
if b=un then exit;
un:=b;
if un then font.style:=[fsunderline]
else font.style:=[];
end;

procedure TForm1.setfarb(s:string);
begin
if farb=s then exit;
farb:=s;
sl.commatext:=farb;
dazu;
sl.strings[0]:=uppercase(sl.strings[0]);
if (sl.strings[0]='VERLAUF1')
or (sl.strings[0]='VERLAUF2')
then begin
verl:=strtoint(sl.strings[0][8]);
links:=wandeln(sl.strings[1]);
rechts:=wandeln(sl.strings[2]);
end else verl:=0;
repaint;
end;

procedure Register;
begin
RegisterComponents('DBR', [TForm1]);
end;

end.

private
{ Private-Deklarationen }
x1, y1, x2, y2: Integer;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Canvas.Pen.Mode := pmNotXOR;
  Canvas.Pen.Style := psDot;
  Timer1.Interval := 200;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button:
  TMouseButton; Shift: TShiftState; x, y: Integer);
begin
  if Shift = [ssLeft] then begin
    Timer1.Enabled := False;
    Canvas.Brush.Style := bsClear;
    x1 := x;
    y1 := y;
    x2 := x;
    y2 := y;
    Canvas.Rectangle(x1, y1, x2, y2);
  end;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState;
  x, y: Integer);
begin
  StatusBar1.SimpleText := IntTostr(x) + ':' + IntTostr(y);
  if Shift = [ssLeft] then begin
    Canvas.Rectangle(x1, y1, x2, y2);
    x2 := x;
    y2 := y;
    Canvas.Rectangle(x1, y1, x2, y2);
  end;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; x, y: Integer);
begin
  Timer1.Enabled := True;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Canvas.Pen.Style := psSolid;
Canvas.Rectangle(x1, y1, x2, y2);
Canvas.Pen.Style := psDot;
end;