Fijate en estas rutinas relacionadas al manejo de color de una imagen llamadas ConvertToGrayScale, ConvertToMonocrome, Iluminate y Negativize:
Código Delphi
[-]procedure TosImage.ConvertToGrayScale(Light:Integer=0;Tint:TColor=clBlack);
var f,n:Integer;
c:TColor;
bm:TBitmap;
begin
if not (Picture.Graphic is TBitmap) then
begin
raise EInvalidGraphicOperation.Create('Image must be a bitmap.');
exit;
end;
if Picture.Bitmap =nil then
begin
raise EInvalidGraphic.Create('Bitmap do not exists.');
exit;
end;
bm:=TBitmap.Create;
bm.Width :=Picture.Bitmap.Width;
bm.Height :=Picture.Bitmap.Height;
for f:=0 to Picture.Bitmap.Height do
for n:=0 to Picture.Bitmap.Width do
begin
c:=ColorToGrayScale(Canvas.Pixels[n,f]);
if Light <> 0 then
c:= ChangeColorLight(c,Light);
if Tint <> clBlack then
c:=GrayScaleToColorScale(ColorToGrayValue(c),Tint);
bm.Canvas.Pixels[n,f]:=c;
end;
Picture.Bitmap.Assign(bm);
bm.free;
end;
Código Delphi
[-]procedure TosImage.ConvertToMonochrome(Range:Byte;ForeColor:TColor=clBlack;BackColor:TColor=clWhite);
var f,n:Integer;
t:Byte;
bm:TBitmap;
begin
if not (Picture.Graphic is TBitmap) then
begin
raise EInvalidGraphicOperation.Create('Image must be a bitmap.');
exit;
end;
if Picture.Bitmap =nil then
begin
raise EInvalidGraphic.Create('Bitmap do not exists.');
exit;
end;
bm:=TBitmap.Create;
bm.Width :=Picture.Bitmap.Width;
bm.Height:=Picture.Bitmap.Height;
for f:=0 to Picture.Bitmap.Height do
for n:=0 to Picture.Bitmap.Width do
begin
t:=ColorToGrayValue(Canvas.Pixels[n,f]);
if t <= Range then
bm.Canvas.Pixels[n,f]:=ForeColor
else
bm.Canvas.Pixels[n,f]:=BackColor;
end;
Picture.Bitmap.Assign(bm);
bm.free;
end;
Código Delphi
[-]procedure TosImage.Iluminate(Light:Integer);
var f,n:Integer;
c:TColor;
bm:TBitmap;
begin
if not (Picture.Graphic is TBitmap) then
begin
raise EInvalidGraphicOperation.Create('Image must be a bitmap.');
exit;
end;
if Picture.Bitmap =nil then
begin
raise EInvalidGraphic.Create('Bitmap do not exists.');
exit;
end;
bm:=TBitmap.Create;
bm.Width :=Picture.Bitmap.Width;
bm.Height :=Picture.Bitmap.Height;
for f:=0 to Picture.Bitmap.Height do
for n:=0 to Picture.Bitmap.Width do
begin
c:=Canvas.Pixels[n,f];
if Light <> 0 then
c:= ChangeColorLight(c,Light);
bm.Canvas.Pixels[n,f]:=c;
end;
Picture.Bitmap.Assign(bm);
bm.free;
end;
Código Delphi
[-]procedure TosImage.Negativize;
var f,n:Integer;
r,g,b:Byte;
bm:TBitmap;
begin
if not (Picture.Graphic is TBitmap) then
begin
raise EInvalidGraphicOperation.Create('Image must be a bitmap.');
exit;
end;
if Picture.Bitmap =nil then
begin
raise EInvalidGraphic.Create('Bitmap do not exists.');
exit;
end;
bm:=TBitmap.Create;
bm.Width :=Picture.Bitmap.Width;
bm.Height :=Picture.Bitmap.Height;
for f:=0 to Picture.Bitmap.Height do
for n:=0 to Picture.Bitmap.Width do
begin
DecodeColor(Canvas.Pixels[n,f],r,g,b);
r:=255-r;
g:=255-g;
b:=255-b;
bm.Canvas.Pixels[n,f]:=EncodeColor(r,g,b);
end;
Picture.Bitmap.Assign(bm);
bm.free;
end;
Código Delphi
[-]procedure TosImage.Negativize;
var f,n:Integer;
r,g,b:Byte;
bm:TBitmap;
begin
if not (Picture.Graphic is TBitmap) then
begin
raise EInvalidGraphicOperation.Create('Image must be a bitmap.');
exit;
end;
if Picture.Bitmap =nil then
begin
raise EInvalidGraphic.Create('Bitmap do not exists.');
exit;
end;
bm:=TBitmap.Create;
bm.Width :=Picture.Bitmap.Width;
bm.Height :=Picture.Bitmap.Height;
for f:=0 to Picture.Bitmap.Height do
for n:=0 to Picture.Bitmap.Width do
begin
DecodeColor(Canvas.Pixels[n,f],r,g,b);
r:=255-r;
g:=255-g;
b:=255-b;
bm.Canvas.Pixels[n,f]:=EncodeColor(r,g,b);
end;
Picture.Bitmap.Assign(bm);
bm.free;
end;
Puedes agregarlas en un control que sea descendiente directo de
TImage;
También necesitarás agregar en ese control estas otras rutinas que son llamadas por las anteriores:
Código Delphi
[-]procedure DecodeCMYK(CMYKColor:Integer; var C,M,Y,K:Byte);
begin
C:= GetCValue(CMYKColor);
M:= GetMValue(CMYKColor);
Y:= GetYValue(CMYKColor);
K:= GetKValue(CMYKColor);
end;
Código Delphi
[-]function EncodeColor(R,G,B:Byte):TColor;
begin
Result:= RGB(R,G,B);
end;
Código Delphi
[-]procedure DecodeColor(Color:TColor; var R,G,B:Byte);
begin
Color:=ColorToRGB(Color);
R:= GetRValue(Color);
G:= GetGValue(Color);
B:= GetBValue(Color);
end;
Código Delphi
[-]procedure DecodeRGB(RGBColor:Integer; var R,G,B:Byte);
begin
R:= GetRValue(RGBColor);
G:= GetGValue(RGBColor);
B:= GetBValue(RGBColor);
end;
Código Delphi
[-]function ColorToGrayScale(Color:TColor):TColor;
var R,G,B:Byte;
begin
DecodeColor(Color,R,G,B);
R:=R*76 div 255;
G:=G*152 div 255;
B:=B*24 div 255;
R:=R+G+B;
Result:=EncodeColor(R,R,R);
end;
Código Delphi
[-]function ColorToGrayValue(Color:TColor):Byte;
var r,g,b:Byte;
begin
DecodeColor(Color,R,G,B);
R:=R*76 div 255;
G:=G*152 div 255;
B:=B*24 div 255;
Result:=R+G+B;
end;
Código Delphi
[-]function BrightenColor(Color:TColor; Change:Byte):TColor;
var r,g,b:Integer;
begin
result:=ColorToRGB(color);
r:= GetRValue(result);
g:= GetGValue(result);
b:= GetBValue(result);
inc(r,Change);
inc(g,Change);
inc(b,Change);
if r>255 then r:=255;
if g>255 then g:=255;
if b>255 then b:=255;
result:= RGB(r,g,b);
end;
Código Delphi
[-]function DarkenColor(Color:TColor; Change:Byte):TColor;
var r,g,b:Integer;
begin
result:=ColorToRGB(color);
r:= GetRValue(result);
g:= GetGValue(result);
b:= GetBValue(result);
dec(r,Change);
dec(g,Change);
dec(b,Change);
if r < 0 then r:=0;
if g < 0 then g:=0;
if b < 0 then b:=0;
result:= RGB(r,g,b);
end;
Código Delphi
[-]function ChangeColorLight(Color:TColor;Change:Integer):TColor;
begin
if Change>0 then
result:=BrightenColor(Color,Change)
else if Change < 0 then
result:=DarkenColor(Color,abs(Change));
end;
Código Delphi
[-]function GrayScaleToColorScale(GrayValue:Byte;Color:TColor):TColor;
var r,g,b:Byte;
begin
DecodeColor(Color,r,g,b);
r:= r+((GrayValue*(256-r))div 256);
g:= g+((GrayValue*(256-g))div 256);
b:= b+((GrayValue*(256-b))div 256);
result:=EncodeColor(r,g,b);
end;
Código Delphi
[-]function ApproachColor(FromColor,ToColor:TColor;Approach:Byte):TColor;
var r1,r2,g1,g2,b1,b2:Byte;
begin
DecodeColor(FromColor,r1,g1,b1);
DecodeColor(ToColor,r2,g2,b2);
if r1 < r2 then
begin
if r1+Approach < r2 then
r1:=r1+Approach
else
r1:=r2;
end
else
begin
if r1-Approach>r2 then
r1:=r1-Approach
else
r1:=r2;
end;
if g1 < g2 then
begin
if g1+Approach < g2 then
g1:=g1+Approach
else
g1:=g2;
end
else
begin
if g1-Approach>g2 then
g1:=g1-Approach
else
g1:=g2;
end;
if b1 < b2 then
begin
if b1+Approach < b2 then
b1:=b1+Approach
else
b1:=b2;
end
else
begin
if b1-Approach>b2 then
b1:=b1-Approach
else
b1:=b2;
end;
result:=EncodeColor(r1,g1,b1);
end;
No están optimizadas para velocidad (no me tomé ese trabajo al escribirlas) pero no son muy lentas
