- Delphiartiklar, tips, forum, länksamling - 

      

START | DELPHI | LÄNKARGÄSTBOK 




 Forum

Grundkurs
  »Introduktion
  »Snabbguide
  »Komponenter
  »Händelser
  »Strängar
  »Räkna med Delphi   »Egna typer
  »Selektion
  »Iteration
  »Menyer
  »Funktioner
  »Arraystrukturer

Tips & Tricks
  »Nya tips
  »Blandat
  »Databaser
  »Filer
  »Forms
  »Grafik
  »Internet
  »Komponenter
  »Matematik
  »Multimedia
  »Objekt/ActiveX
  »Skrivare
  »Strängar
  »System
  »Mest lästa tips

Artiklar
  »Delphi och ADO
  »Bygga en DLL
  »Skapa en enkel rapport
  »Hantera registret
  »Enheter, units
  »Klassen TCanvas
  »Använd LookUp Controls

 Nya tips
 Lägg till tips
 Delphilänkar
 Gästbok

 

Rita upp ett regnbågsspektrum på ditt formulär Kategori: Grafik
Inlagt: 2006-05-31
Läst: 1172
Inlagt av: Staffan Berg
Beskrivning
Detta exempel ritar upp en snygg regnbågseffekt på ditt formulär.
Kod
procedure PaintRainbow(Dc : hDc; {Canvas to paint to} 
            x : integer; {Start position X} 
            y : integer; {Start position Y} 
            Width : integer; {Width of the rainbow} 
            Height : integer {Height of the rainbow}; 
            bVertical : bool; {Paint verticallty} 
            WrapToRed : bool); {Wrap spectrum back to red} 
var 
 i : integer; 
 ColorChunk : integer; 
 OldBrush : hBrush; 
 OldPen : hPen; 
 r : integer; 
 g : integer; 
 b : integer; 
 Chunks : integer; 
 ChunksMinus1 : integer; 
 pt : TPoint; 
begin 
 OffsetViewportOrgEx(Dc, 
           x, 
           y, 
           pt); 
 
 if WrapToRed = false then 
  Chunks := 5 else 
  Chunks := 6; 
 ChunksMinus1 := Chunks - 1; 
 
 if bVertical = false then 
  ColorChunk := Width div Chunks else 
  ColorChunk := Height div Chunks; 
 
//Red To Yellow 
 r := 255; 
 b := 0; 
 for i := 0 to ColorChunk do begin 
  g:= (255 div ColorChunk) * i; 
  OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); 
  if bVertical = false then 
   PatBlt(Dc, i, 0, 1, Height, PatCopy) else 
   PatBlt(Dc, 0, i, Width, 1, PatCopy); 
  DeleteObject(SelectObject(Dc, OldBrush)); 
 end; 
 
//Yellow To Green 
 g:=255; 
 b:=0; 
 for i := ColorChunk to (ColorChunk * 2) do begin 
  r := 255 - (255 div ColorChunk) * (i - ColorChunk); 
  OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); 
  if bVertical = false then 
   PatBlt(Dc, i, 0, 1, Height, PatCopy) else 
   PatBlt(Dc, 0, i, Width, 1, PatCopy); 
  DeleteObject(SelectObject(Dc, OldBrush)); 
 end; 
 
//Green To Cyan 
 r:=0; 
 g:=255; 
 for i:= (ColorChunk * 2) to (ColorChunk * 3) do begin 
  b := (255 div ColorChunk)*(i - ColorChunk * 2); 
  OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); 
  if bVertical = false then 
   PatBlt(Dc, i, 0, 1, Height, PatCopy) else 
   PatBlt(Dc, 0, i, Width, 1, PatCopy); 
  DeleteObject(SelectObject(Dc,OldBrush)); 
 end; 
 
//Cyan To Blue 
 r := 0; 
 b := 255; 
 for i:= (ColorChunk * 3) to (ColorChunk * 4) do begin 
  g := 255 - ((255 div ColorChunk) * (i - ColorChunk * 3)); 
  OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); 
  if bVertical = false then 
   PatBlt(Dc, i, 0, 1, Height, PatCopy) else 
   PatBlt(Dc, 0, i, Width, 1, PatCopy); 
  DeleteObject(SelectObject(Dc, OldBrush)); 
 end; 
 
//Blue To Magenta 
 g := 0; 
 b := 255; 
 for i:= (ColorChunk * 4) to (ColorChunk * 5) do begin 
  r := (255 div ColorChunk) * (i - ColorChunk * 4); 
  OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); 
  if bVertical = false then 
   PatBlt(Dc, i, 0, 1, Height, PatCopy) else 
   PatBlt(Dc, 0, i, Width, 1, PatCopy); 
  DeleteObject(SelectObject(Dc, OldBrush)) 
 end; 
 
 if WrapToRed <> false then begin 
  //Magenta To Red 
  r := 255; 
  g := 0; 
  for i := (ColorChunk * 5) to ((ColorChunk * 6) - 1) do begin 
   b := 255 -((255 div ColorChunk) * (i - ColorChunk * 5)); 
   OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r,g,b))); 
   if bVertical = false then 
    PatBlt(Dc, i, 0, 1, Height, PatCopy) else 
    PatBlt(Dc, 0, i, Width, 1, PatCopy); 
   DeleteObject(SelectObject(Dc,OldBrush)); 
  end; 
 end; 
 
//Fill Remainder 
 if (Width - (ColorChunk * Chunks) - 1 ) > 0 then begin 
  if WrapToRed <> false then begin 
   r := 255; 
   g := 0; 
   b := 0; 
  end else begin 
   r := 255; 
   g := 0; 
   b := 255; 
  end; 
  OldBrush := SelectObject(Dc, CreateSolidBrush(Rgb(r, g, b))); 
  if bVertical = false then 
   PatBlt(Dc, 
       ColorChunk * Chunks, 
       0, 
       Width - (ColorChunk * Chunks), 
       Height, 
       PatCopy) else 
   PatBlt(Dc, 
       0, 
       ColorChunk * Chunks, 
       Width, 
       Height - (ColorChunk * Chunks), 
       PatCopy); 
  DeleteObject(SelectObject(Dc,OldBrush)); 
 end; 
 OffsetViewportOrgEx(Dc, 
           Pt.x, 
           Pt.y, 
           pt); 
end; 
 
function ColorAtRainbowPoint(ColorPlace : integer; 
               RainbowWidth : integer; 
               WrapToRed : bool) : TColorRef; 
var 
 ColorChunk : integer; 
 ColorChunkIndex : integer; 
 ColorChunkStart : integer; 
begin 
 if ColorPlace = 0 then begin 
  result := RGB(255, 0, 0); 
  exit; 
end; 
//WhatChunk 
 if WrapToRed <> false then 
  ColorChunk := RainbowWidth div 6 else 
  ColorChunk := RainbowWidth div 5; 
  ColorChunkStart := ColorPlace div ColorChunk; 
  ColorChunkIndex := ColorPlace mod ColorChunk; 
 case ColorChunkStart of 
  0 : result := RGB(255, 
           (255 div ColorChunk) * ColorChunkIndex, 
           0); 
  1 : result := RGB(255 - (255 div ColorChunk) * ColorChunkIndex, 
           255, 
           0); 
  2 : result := RGB(0, 255, (255 div ColorChunk) * ColorChunkIndex); 
  3 : result := RGB(0, 
           255 - (255 div ColorChunk) * ColorChunkIndex, 
           255); 
  4 : result := RGB((255 div ColorChunk) * ColorChunkIndex, 
           0, 
           255); 
  5 : result := RGB(255, 
           0, 
           255 - (255 div ColorChunk) * ColorChunkIndex); 
 else 
  if WrapToRed <> false then 
   result := RGB(255, 0, 0) else 
   result := RGB(255, 0, 255); 
 end;//Case 
end; 
 
 
procedure TForm1.FormPaint(Sender: TObject); 
begin 
 PaintRainbow(Form1.Canvas.Handle, 
        0, 
        0, 
        Form1.ClientWidth, 
        Form1.ClientHeight, 
        false, 
        true); 
 
end; 
 
procedure TForm1.FormResize(Sender: TObject); 
begin 
 InvalidateRect(Form1.Handle, nil, false); 
end; 
 
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; 
 Shift: TShiftState; X, Y: Integer); 
var 
 Color : TColorRef; 
begin 
 Color := ColorAtRainbowPoint(y, 
                Form1.ClientWidth, 
                true); 
 ShowMessage(IntToStr(GetRValue(Color)) + #32 + 
       IntToStr(GetGValue(Color)) + #32 + 
       IntToStr(GetBValue(Color))); 
end; 

 
 
© Copyright 2005 - Staffan Berg
- Alla rättigheter förbehålles -