Mega Code Archive
Images treatment
<![CDATA[
Title: Images treatment
Question: work with images in delphi
Answer:
{***********************************************************************************
* blLibrary - [Bitmap Library] v1.0 *
* Libreria para el trabajo con Bitmaps en Delphi *
************************************************************************************
* *
* Esta libreria ha sido implementada por _Fidel Hernandez Salazar *
* Puede usarla a su antojo si promete llevar siempre junto con sus *
* distrubuciones el nombre del autor original. *
* *
* .:Advertencia:. *
* No me hago responsable por el mal uso de esta libreria y mucho *
* menos por la perdida de informacion si se trabaja con la misma. *
* *
************************************************************************************
* Implementada en Borland Delphi 7 Enterprise Edition *
************************************************************************************}
unit blUnit;
interface
uses
Windows, SysUtils, Graphics, Classes;
procedure bl_ChangeRGB(var Bitmap: TBitmap; R, G, B: Integer);
procedure bl_Flaxen(var Bitmap: TBitmap);
procedure bl_Emboss(var Bitmap : TBitmap; AMount : Integer);
procedure bl_MonoNoise(var Bitmap: TBitmap; Amount: Integer);
procedure bl_ColorNoise(var Bitmap: TBitmap; Amount: Integer);
procedure bl_GrayScale(var Bitmap: TBitmap);
procedure bl_Sepia (var Bitmap: TBitmap; depth: Byte);
procedure bl_Blur( var Bitmap : TBitmap);
procedure bl_Lightness(var Bitmap: TBitmap; Amount: Integer);
procedure bl_Darkness(var Bitmap: TBitmap; Amount: Integer);
procedure bl_Threshold(var Bitmap: TBitmap ; const Light: TRgbTriple; const Dark: TRgbTriple; Amount: Integer = 128);
procedure bl_Posterize(var Bitmap: TBitmap; amount: Integer);
procedure bl_Mosaic(var Bm:TBitmap;size:Integer);
procedure bl_FlipHorizontal(var Bitmap: TBitmap);
procedure bl_FlipVertical(var Bitmap: TBitmap);
procedure bl_Negative(var Bitmap: TBitmap);
procedure bl_Saturation(var Bitmap: TBitmap; Amount: Integer);
procedure bl_Contrast(var Bitmap: TBitmap; Amount: Integer);
function bl_ColorToTriple(Color: TColor): TRGBTriple;
function bl_IntToByte(I: Integer): Byte;
implementation
function bl_IntToByte(i: Integer): Byte;
begin
if i 255 then
Result := 255
else if i 0 then
Result := 0
else
Result := i;
end;
function bl_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 ;
procedure bl_ChangeRGB(var Bitmap: TBitmap; R, G, B: Integer);
var
H, V: Integer;
DstRow:^TRGBTriple;
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^.rgbtRed := R;
DstRow^.rgbtGreen := G;
DstRow^.rgbtBlue := B;
Inc(DstRow);
end;
end;
end;
procedure bl_Flaxen(var 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;
procedure bl_Emboss(var 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;
procedure bl_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 :=bl_IntToByte(Row.rgbtBlue+a);
Row.rgbtGreen :=bl_IntToByte(Row.rgbtGreen+a);
Row.rgbtRed :=bl_IntToByte(Row.rgbtRed+a);
inc(Row);
end;
end;
end;
procedure bl_ColorNoise(var 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^:=bl_IntToByte(Wsk^+(Random(Amount)-(Amount shr 1)));
inc(Wsk);
end;
end;
end;
procedure bl_GrayScale(var Bitmap:TBitmap);
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);
Row.rgbtBlue:=Index;
Row.rgbtGreen:=Index;
Row.rgbtRed:=Index;
inc(Row);
end;
end;
end;
procedure bl_Sepia (var 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);
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;
procedure bl_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;
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
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;
procedure bl_Lightness(var 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^:=bl_IntToByte(Wsk^+((255-Wsk^)*Amount)div 255);
inc(Wsk);
end;
end;
end;
procedure bl_Darkness(var 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^:=bl_IntToByte(Wsk^-(Wsk^*Amount)div 255);
inc(Wsk);
end;
end;
end;
procedure bl_Threshold(var 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 IndexAmount then
Row^:=Light else Row^:=Dark ;
inc(Row);
end;
end;
end;
procedure bl_Posterize(var 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;
procedure bl_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 (isize);
until x=bm.width;
inc(j);
inc(y);
until (y=bm.height) or (jsize);
until (y=bm.height) or (x=bm.width);
until y=bm.height;
end;
procedure bl_FlipHorizontal(var Bitmap:TBitmap);
type
ByteTriple =array[0..2] of byte;
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;
procedure bl_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;
procedure bl_Negative(var Bitmap:TBitmap);
var
H,V:Integer;
WskByte:^Byte;
begin
Bitmap.PixelFormat:=pf24bit;
for V:=0 to Bitmap.Height-1 do
begin
WskByte:=Bitmap.ScanLine[V];
for H:=0 to (Bitmap.Width *3)-1 do
begin
WskByte^:= not WskByte^ ;
inc(WskByte);
end;
end;
end;
procedure bl_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:=bl_IntToByte(Gray+(((Wsk.rgbtRed-Gray)*Amount)div 255));
Wsk.rgbtGreen:=bl_IntToByte(Gray+(((Wsk.rgbtGreen-Gray)*Amount)div 255));
Wsk.rgbtBlue:=bl_IntToByte(Gray+(((Wsk.rgbtBlue-Gray)*Amount)div 255));
inc(Wsk);
end;
end;
end;
procedure bl_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^:=bl_IntToByte(ByteWsk^+(Abs(127-ByteWsk^)*Amount)div 255)
else ByteWsk^:=bl_IntToByte(ByteWsk^-(Abs(127-ByteWsk^)*Amount)div 255);
Inc(ByteWsk);
end;
end;
end;
end.
]]>