Images-treatment


            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.
Graphic Delphi
