Never been to TextSnippets before?

Snippets is a public source code repository. Easily build up your personal collection of code snippets, categorize them with tags / keywords, and share them with the world (or not, you can keep them private!)

« Newer Snippets
Older Snippets »
21 total  XML / RSS feed 

Zmiana wartości RGB z blokadą przepełnienia

procedure ChangeRGB(var Bitmap:TBitmap;R,G,B:integer);
var
H,V:integer;
DstRow:^TRGBTriple; // to jest wskaźnik dopixela
begin
 Bitmap.PixelFormat:=pf24bit;
 for V:=0 to Bitmap.Height -1 do
  begin
      DstRow:=Bitmap.ScanLine[V];
      for H:=0 to Bitmap.Width -1 do
      begin
      DstRow^:=ChangeRGBColor(DStrow^,R,G,B);
       Inc(DstRow);
     end;
  end;
end;
to color rgb delphi by drs on May 07, 2007

Flaxen

procedure Flaxen( Bitmap:TBitmap);
var
H,V:Integer;
WSK,WSK2,WSK3:^TRGBTriple;

begin
Bitmap.PixelFormat:=pf24bit;
for V:=0 to Bitmap.Height-1 do
  begin
Wsk:=Bitmap.ScanLine[V];
Wsk2:=Wsk;
Wsk3:=Wsk;
inc(Wsk2);
inc(Wsk3,2);

for H:=0 to Bitmap.Width -1 do
    begin
    Wsk.rgbtRed  := (Wsk.rgbtRed + Wsk2.rgbtGreen  +
    Wsk3.rgbtBlue) div 3;
    Wsk2.rgbtGreen := (Wsk.rgbtGreen + Wsk2.rgbtGreen +
    Wsk3.rgbtBlue) div 3;
    Wsk2.rgbtBlue := (Wsk.rgbtBlue + Wsk2.rgbtGreen +
    Wsk3.rgbtBlue) div 3;
    inc(Wsk);inc(Wsk2);inc(Wsk3);
    end;
  end;
end;
to image delphi effect flaxen by drs on May 07, 2007

Emboss

procedure Emboss(Bitmap : TBitmap; AMount : Integer);
   var
   x, y, i : integer;
  p1, p2: PByteArray;
begin
  for i := 0 to AMount do
  begin
    for y := 0 to Bitmap.Height-2 do
    begin
      p1 := Bitmap.ScanLine[y];
      p2 := Bitmap.ScanLine[y+1];
      for x := 0 to Bitmap.Width do
      begin
        p1[x*3] := (p1[x*3]+(p2[(x+3)*3] xor $FF)) shr 1;
        p1[x*3+1] := (p1[x*3+1]+(p2[(x+3)*3+1] xor $FF)) shr 1;
        p1[x*3+2] := (p1[x*3+1]+(p2[(x+3)*3+1] xor $FF)) shr 1;
      end;
    end;
  end;
end;
to image delphi effect emboss by drs on May 07, 2007

Mono Noise

procedure MonoNoise(var Bitmap: TBitmap; Amount: Integer);
var
Row:^TRGBTriple;
H,V,a: Integer;
begin
  for V:=0 to Bitmap.Height-1 do
  begin
    Row:=Bitmap.ScanLine[V];
    for H:=0 to Bitmap.Width-1 do
    begin
      a:=Random(Amount)-(Amount shr 1);

      Row.rgbtBlue :=IntToByte(Row.rgbtBlue+a);
      Row.rgbtGreen :=IntToByte(Row.rgbtGreen+a);
      Row.rgbtRed :=IntToByte(Row.rgbtRed+a);
      inc(Row);
    end;
  end;
end;
to image delphi effect noise mono by drs on May 07, 2007

Color Noise

procedure ColorNoise( Bitmap: TBitmap; Amount: Integer);
var
WSK:^Byte;
H,V,a: Integer;
begin
Bitmap.PixelFormat:=pf24bit;
  for V:=0 to Bitmap.Height-1 do
  begin
    Wsk:=Bitmap.ScanLine[V];
    for H:=0 to Bitmap.Width*3-1 do
    begin
    Wsk^:=IntToByte(Wsk^+(Random(Amount)-(Amount shr 1)));
      inc(Wsk);
    end;
  end;
end;
to image color delphi effect noise by drs on May 07, 2007

GrayScale

// description of your code here

Procedure GrayScale(var Bitmap:TBitmap);
var
Row:^TRGBTriple; // wskaźnik do rekordu reprezentującego składowe RGB Pixela
H,V,Index:Integer;
begin
 Bitmap.PixelFormat:=pf24bit;
 for V:=0 to Bitmap.Height-1 do
  begin
    Row:=Bitmap.ScanLine[V];
    for H:=0 to Bitmap.Width -1 do
    begin
    Index := ((Row.rgbtRed * 77 +       //77 to stała dla czerwieni
       Row.rgbtGreen* 150 +           //150 stała dla zielonego
       Row.rgbtBlue * 29) shr 8);    //29  stała dla niebieskiego
       Row.rgbtBlue:=Index;
       Row.rgbtGreen:=Index;
       Row.rgbtRed:=Index;
       inc(Row); { Nie wolno przypisywać X:=0 lub 1,2 bo to Wskaźnk!!!
 poruszamy się inc() lub dec()}

    end;
  end;
end;
to image delphi effect grayscale by drs on May 07, 2007

Sepia

procedure Sepia ( Bitmap:TBitmap;depth:byte);
var
Row:^TRGBTriple;
H,V:Integer;
begin
 Bitmap.PixelFormat:=pf24bit;
 for V:=0 to Bitmap.Height-1 do
  begin
    Row:=Bitmap.ScanLine[V];
    for H:=0 to Bitmap.Width -1 do
    begin
      Row.rgbtBlue :=(Row.rgbtBlue +Row.rgbtGreen +Row.rgbtRed)div 3;
      Row.rgbtGreen:=Row.rgbtBlue;
      Row.rgbtRed  :=Row.rgbtBlue;
      inc(Row.rgbtRed,depth*2); //dodane wartosci
      inc(Row.rgbtGreen,depth);
      if Row.rgbtRed < (depth*2) then Row.rgbtRed:=255;
      if  Row.rgbtGreen < (depth) then Row.rgbtGreen:=255;
      inc(Row);
    end;
  end;
end;
to image delphi effect sepia by drs on May 07, 2007

Blur

Procedure Blur( var Bitmap :TBitmap);
var
TL,TC,TR,BL,BC,BR,LL,LC,LR:^TRGBTriple;
H,V:Integer;
begin
Bitmap.PixelFormat :=pf24bit;
for V := 1 to Bitmap.Height - 2 do
begin
TL:= Bitmap.ScanLine[V - 1];
TC:=TL;    // to samo Scanline  Bitmap.ScanLine[V - 1]; tylko oszczędniej
TR:=TL;
BL:= Bitmap.ScanLine[V];
BC:=BL;
BR:=BL;
LL:= Bitmap.ScanLine[V + 1];
LC:=LL;
LR:=LL;
inc(TC); inc(TR,2);
inc(BC); inc(BR,2);
inc(LC); inc(LR,2);

for H := 1 to (Bitmap.Width  - 2) do
begin
//Wyciągam srednią z 9 sąsiadujących pixeli
  BC.rgbtRed:= (BC.rgbtRed+ BL.rgbtRed+BR.rgbtRed+
  TC.rgbtRed+ TL.rgbtRed+TR.rgbtRed+
  LL.rgbtRed+ LC.rgbtRed+LR.rgbtRed) div 9 ;

  BC.rgbtGreen:=( BC.rgbtGreen+ BL.rgbtGreen+BR.rgbtGreen+
  TC.rgbtGreen+ TL.rgbtGreen+TR.rgbtGreen+
  LL.rgbtGreen+ LC.rgbtGreen+LR.rgbtGreen) div 9 ;

  BC.rgbtBlue:=( BC.rgbtBlue+ BL.rgbtBlue+BR.rgbtBlue+
  TC.rgbtBlue+ TL.rgbtBlue+TR.rgbtBlue+
  LL.rgbtBlue+ LC.rgbtBlue+LR.rgbtBlue )div 9 ;
//zwiększam wskaźniki biorąc następne 9 pixeli
  inc(TL);inc(TC);inc(TR);
  inc(BL);inc(BC);inc(BR);
  inc(LL);inc(LC);inc(LR);
    end;
  end;
end;
to image delphi effect blur by drs on May 07, 2007

Lightness

procedure Lightness( Bitmap:TBitmap; Amount: Integer);
var
Wsk:^Byte;
H,V: Integer;
begin
Bitmap.PixelFormat:=Graphics.pf24bit;
  for V:=0 to Bitmap.Height-1 do
  begin
    Wsk:=Bitmap.ScanLine[V];
    for H:=0 to Bitmap.Width*3-1 do
    begin
    Wsk^:=IntToByte(Wsk^+((255-Wsk^)*Amount)div 255);
    inc(Wsk);
    end;
  end;
end;
to image delphi effect Lightness by drs on May 07, 2007

Darkness

procedure Darkness( Bitmap:TBitmap; Amount: integer);
var
Wsk:^Byte;
H,V: Integer;
begin
  Bitmap.pixelformat:=pf24bit;
  for V:=0 to Bitmap.Height-1 do begin
    WSK:=Bitmap.ScanLine[V];
    for H:=0 to Bitmap.Width*3-1 do
    begin
    Wsk^:=IntToByte(Wsk^-(Wsk^*Amount)div 255);
    inc(Wsk);
  end;
 end;
end;
to image delphi effect darkness by drs on May 07, 2007

Threshold

funkcja przetwarza Bitmapę na 2 kolorową o podanych kolorach (odpowiadającym ciemniejszemu-Dark
i jaśniejszemu -Light w zależności od podanego progu -Amout rozgraniczającego odcienie (domyślnie128 );
jeśli chcemy użyć zmiennych TColor należy użyć funkcji ColorToTriple (powyżej).

procedure Threshold( Bitmap:TBitmap ; const Light:TRgbTriple; const Dark:TRgbTriple; Amount:Integer = 128);
var
Row:^TRGBTriple;
H,V,Index:Integer;
begin
 Bitmap.PixelFormat:=pf24bit;
 for V:=0 to Bitmap.Height-1 do
  begin
    Row:=Bitmap.ScanLine[V];
    for H:=0 to Bitmap.Width -1 do
    begin
    Index := ((Row.rgbtRed * 77 +
       Row.rgbtGreen* 150 +
       Row.rgbtBlue * 29) shr 8);
       if Index>Amount then
      Row^:=Light  else Row^:=Dark ;
       inc(Row);
    end;
  end;
end;
to image delphi effect threshold by drs on May 07, 2007

Posterize

procedure Posterize(Bitmap: TBitmap; amount: integer);
var
H,V:Integer;
Wsk:^Byte;
begin
  Bitmap.PixelFormat :=pf24bit;
  for V:=0 to Bitmap.Height -1 do
  begin
   Wsk:=Bitmap.scanline[V];
   for H:=0 to Bitmap.Width*3 -1 do
   begin
     Wsk^:= round(WSK^/amount)*amount ;
     inc(Wsk);
     end;
   end;
end;
to image delphi effect posterize by drs on May 07, 2007

Mosaic

procedure Mosaic(var Bm:TBitmap;size:Integer);
var
   x,y,i,j:integer;
   p1,p2:pbytearray;
   r,g,b:byte;
begin
  y:=0;
  repeat
    p1:=bm.scanline[y];
    x:=0;
    repeat
      j:=1;
      repeat
      p2:=bm.scanline[y];
      x:=0;
      repeat
        r:=p1[x*3];
        g:=p1[x*3+1];
        b:=p1[x*3+2];
        i:=1;
       repeat
       p2[x*3]:=r;
       p2[x*3+1]:=g;
       p2[x*3+2]:=b;
       inc(x);
       inc(i);
       until (x>=bm.width) or (i>size);
      until x>=bm.width;
      inc(j);
      inc(y);
      until (y>=bm.height) or (j>size);
    until (y>=bm.height) or (x>=bm.width);
  until y>=bm.height;
end;
to image delphi effect mosaic by drs on May 07, 2007

Flip Horizontal

Procedura odbija bitmapę względem osi Y

procedure FlipHorizontal(var Bitmap:TBitmap);
type
ByteTriple =array[0..2] of byte        ; // musimy czytać po 3 bajty żeby nie zamienić kolejności BGR na RGB
var
ByteL,ByteR:^ByteTriple;
ByteTemp:ByteTriple;
H,V:Integer;
begin
Bitmap.PixelFormat:=pf24bit;
for V:=0 to (Bitmap.Height -1 )  do
  begin
  ByteL:=Bitmap.ScanLine[V];
  ByteR:=Bitmap.ScanLine[V];
  inc(ByteR,Bitmap.Width -1);
    for H:=0 to (Bitmap.Width -1) div 2  do
    begin
    ByteTemp:=ByteL^;
    ByteL^:=ByteR^;
    ByteR^:=ByteTemp;
    Inc(ByteL);
    Dec(ByteR);
    end;
  end;
end;
to image delphi flip horizontal by drs on May 07, 2007

Flip Vertical

Procedura odbija bitmapę względem osi X
procedure FlipVertical(var Bitmap:TBitmap);
var
ByteTop,ByteBottom:^Byte;
ByteTemp:Byte;
H,V:Integer;
begin
for V:=0 to (Bitmap.Height -1 ) div 2 do
  begin
  ByteTop:=Bitmap.ScanLine[V];
  ByteBottom:=Bitmap.ScanLine[Bitmap.Height -1-V];
  for H:=0 to Bitmap.Width *3 -1 do
    begin
    ByteTemp:=ByteTop^;
    ByteTop^:=ByteBottom^;
    ByteBottom^:=ByteTemp;
    inc(ByteTop);
    inc(ByteBottom);
    end;
  end;
end;de
to image delphi flip vertical by drs on May 07, 2007

Negative

procedure Negative(var Bitmap:TBitmap);
var
H,V:Integer;
WskByte:^Byte; //Wskaźnik do Bajta (nie trzeba do całego pixela bo i tak wszystko odwracamy)
begin
Bitmap.PixelFormat:=pf24bit;
for V:=0 to Bitmap.Height-1 do
  begin
    WskByte:=Bitmap.ScanLine[V]; // V jest to pozycja  danej linii bitmapy (od góry )
    for  H:=0 to (Bitmap.Width *3)-1 do
    begin
      WskByte^:= not WskByte^ ;// (odwracamy wartość na którą pokazuje wskaźnik)
      inc(WskByte);//Przesuwam wskaźnik
    end;
  end;
end;
to image color delphi negative by drs on May 07, 2007

Saturation

procedure Saturation(var  Bitmap: TBitmap; Amount: Integer);
var
Wsk:^TRGBTriple;
Gray,H,V: Integer;
begin
  for V:=0 to Bitmap.Height-1 do
  begin
    Wsk:=Bitmap.ScanLine[V];
    for H:=0 to Bitmap.Width-1 do
    begin

    Gray:=(Wsk.rgbtBlue+Wsk.rgbtGreen+Wsk.rgbtRed)div 3;
    Wsk.rgbtRed:=IntToByte(Gray+(((Wsk.rgbtRed-Gray)*Amount)div 255));
    Wsk.rgbtGreen:=IntToByte(Gray+(((Wsk.rgbtGreen-Gray)*Amount)div 255));
    Wsk.rgbtBlue:=IntToByte(Gray+(((Wsk.rgbtBlue-Gray)*Amount)div 255));
    inc(Wsk);
    end;
  end;
end;
to color delphi saturation by drs on May 07, 2007

Kontrast

procedure Contrast(var Bitmap:TBitmap; Amount: Integer);
var
ByteWsk:^Byte;
H,V:  Integer;
begin
  for V:=0 to Bitmap.Height-1 do
  begin
    ByteWsk:=Bitmap.ScanLine[V];
    for H:=0 to Bitmap.Width*3 -1  do
    begin
      if ByteWsk^>127 then
      ByteWsk^:=IntToByte(ByteWsk^+(Abs(127-ByteWsk^)*Amount)div 255)
      else ByteWsk^:=IntToByte(ByteWsk^-(Abs(127-ByteWsk^)*Amount)div 255);
      Inc(ByteWsk);
    end;
  end;
end;
to color delphi contrast by drs on May 07, 2007

IntToByte

Funkcja zamienia wartość integer na byte.

function IntToByte(i:Integer):Byte;
begin
  if i > 255 then
    Result := 255
  else if i < 0 then
    Result := 0
  else
    Result := i;
end;
to delphi int byte by drs on May 07, 2007

ColorToTriple

Funkcja zamienia wartość TColor na TRGBTriple.

function ColorToTriple(Color:TColor):TRGBTriple;
type
Rec=Record
Case TColor of
1:( ColorValue:TColor );
2:(Bytes: array [0..3] of Byte);
end;
var
Col:Rec;
begin
Col.ColorValue:= Color;

Result.rgbtRed :=Col.Bytes[0];
Result.rgbtGreen :=Col.Bytes[1];
Result.rgbtBlue :=Col.Bytes[2];
end ;
to color rgb delphi triple by drs on May 07, 2007
« Newer Snippets
Older Snippets »
21 total  XML / RSS feed