- Exportar el contenido de un TImage al formato Microsoft Clippart de Office
- Efecto Fade out de un bitmap
- Invertir los colores de un tImage
- Grabar un metafile guardado en un tImage como un bitmap
- Cargar y ajustar una imagen jpeg dentro de un tImage
- Pon un color invisible de una imagen transparente
- Transforma un bitmap a escala de grises
- Carga una imagen JPG en un tImage preservando el ratio de aspecto
- Escalar un bitmap por porcentaje
- Crear thumbnails
- Encriptar un bmp
- Cargar una imagen jpg en un bmp
- Cargar un bmp en un timage
- Leer un bitmap pixel a pixel
- Modificar un pixel de un bitmap
- Cambiar el color del canal Alpha de un Bitmap
- Convertir imagen png en bmp
- Convertir imagen bmp en png
Exportar el contenido de un TImage al formato Microsoft Clippart de Office
procedure ExportBMPtoWMF(Imagem: TImage; Dest: Pchar);
VAR
Metafile: TMetafile;
MetafileCanvas: TMetafileCanvas;
DC: HDC;
ScreenLogPixels: Integer;
BEGIN
Metafile := TMetafile.Create;
TRY
DC := GetDC(0);
ScreenLogPixels := GetDeviceCaps(DC, LOGPIXELSY);
Metafile.Inch := ScreenLogPixels;
Metafile.Width := Imagem.Picture.Bitmap.Width;
Metafile.Height := Imagem.Picture.Bitmap.Height;
MetafileCanvas := TMetafileCanvas.Create(Metafile, DC);
ReleaseDC(0, DC);
TRY
MetafileCanvas.Draw(0, 0, Imagem.Picture.Bitmap);
FINALLY
MetafileCanvas.Free;
END;
Metafile.Enhanced := FALSE;
Metafile.SaveToFile(Dest);
FINALLY
Metafile.Destroy;
END;
END;
Efecto Fade out de un bitmap
PROCEDURE TForm1.Button1Click(Sender: TObject);
PROCEDURE FadeOut(CONST BMP: TImage; Pause: integer);
VAR
BytesPorScan: integer;
w, h: integer;
p: pByteArray;
counter: integer;
BEGIN
{ Sólo funciona para bitmaps de 24 o 32 bits}
IF NOT (BMP.Picture.Bitmap.PixelFormat IN [pf24Bit, pf32Bit]) THEN
RAISE exception.create('Error, bitmap format not supported.');
TRY
BytesPorScan := Abs(Integer(BMP.Picture.Bitmap.ScanLine[1]) -
Integer(BMP.Picture.Bitmap.ScanLine[0]));
EXCEPT
RAISE exception.create('Error');
END;
{ Degrada los componentes RGB de cada pixel }
FOR counter := 1 TO 256 DO
BEGIN
FOR h := 0 TO BMP.Picture.Bitmap.Height - 1 DO
BEGIN
P := BMP.Picture.Bitmap.ScanLine[h];
FOR w := 0 TO BytesPorScan - 1 DO
IF P^[w]> 0 THEN
P^[w] := P^[w] - 1;
END;
Sleep(Pause);
BMP.Refresh;
END;
END; {procedure FadeOut}
BEGIN
FadeOut(Image1, 5);
END;
Invertir los colores de un tImage
Image1.Canvas.CopyMode := cmDstInvert;
Image1.Canvas.CopyRect(Image1.ClientRect, Image1.Canvas, Image1.ClientRect);
imgZoom.Canvas.CopyMode := cmSrcCopy;
Grabar un metafile guardado en un tImage como un bitmap
{ ... }
VAR
aBitmap: TBitmap;
BEGIN
aBitmap := TBitmap.Create;
aBitmap.width := Image.picture.width;
aBitmap.height := Image1.picture.height;
TRY
aBitmap.Canvas.Draw(0, 0, Image1.Picture.Metafile);
abitmap.SaveToFile('D:\temp\mybit.bmp');
FINALLY
aBitmap.free;
END;
Cargar y ajustar una imagen jpeg dentro de un tImage
{ ... }
Image1.Picture.Graphic := NIL;
TRY
Image1.Picture.Graphic := NIL;
Image1.Picture.LoadFromFile(jpegfile);
EXCEPT
ON EInvalidGraphic DO
Image1.Picture.Graphic := NIL;
END;
IF Image1.Picture.Graphic IS TJPEGImage THEN
BEGIN
TJPEGImage(Image1.Picture.Graphic).Scale := Self.Scale;
TJPEGImage(Image1.Picture.Graphic).Performance := jpBestSpeed;
END;
Pon un color invisible de una imagen transparente
PROCEDURE TForm1.FormCreate(Sender: TObject);
BEGIN
WITH Image1.Picture.Bitmap DO
BEGIN
TransparentColor := clMaroon;
TransparentMode := tmFixed;
END;
END;
Transforma un bitmap a escala de grises
PROCEDURE ImageGrayScale(VAR AnImage: TImage);
VAR
JPGImage: TJPEGImage;
BMPImage: TBitmap;
MemStream: TMemoryStream;
BEGIN
BMPImage := TBitmap.Create;
TRY
BMPImage.Width := AnImage.Picture.Bitmap.Width;
BMPImage.Height := AnImage.Picture.Bitmap.Height;
JPGImage := TJPEGImage.Create;
TRY
JPGImage.Assign(AnImage.Picture.Bitmap);
JPGImage.CompressionQuality := 100;
JPGImage.Compress;
JPGImage.Grayscale := True;
BMPImage.Canvas.Draw(0, 0, JPGImage);
MemStream := TMemoryStream.Create;
TRY
BMPImage.SaveToStream(MemStream);
//you need to reset the position of the MemoryStream to 0
MemStream.Position := 0;
AnImage.Picture.Bitmap.LoadFromStream(MemStream);
AnImage.Refresh;
FINALLY
MemStream.Free;
END;
FINALLY
JPGImage.Free;
END;
FINALLY
BMPImage.Free;
END;
END; //fin de ImageGrayScale
Carga una imagen JPG en un tImage preservando el ratio de aspecto
PROCEDURE TForm1.Button1Click(Sender: TObject);
PROCEDURE CargaJPGProporcionado(Fichero: STRING;
CONST QueImage: TImage);
VAR
ElJPG: TJpegImage;
Rectangulo: TRect;
EscalaX,
EscalaY,
Escala: Single;
BEGIN
ElJPG := TJPegImage.Create;
TRY
ElJPG.LoadFromFile(Fichero);
//Por defecto, escala 1:1
EscalaX := 1.0;
EscalaY := 1.0;
//Hallamos la escala de reducción Horizontal
IF QueImage.Width < ElJPG.Width THEN
EscalaX := QueImage.Width / ElJPG.Width;
//La escala vertical
IF QueImage.Height < ElJPG.Height THEN
EscalaY := QueImage.Height / ElJPG.Height;
//Escogemos la menor de las 2
IF EscalaY < EscalaX THEN
Escala := EscalaY
ELSE
Escala := EscalaX;
//Y la usamos para reducir el rectangulo destino
WITH Rectangulo DO
BEGIN
Right := Trunc(ElJPG.Width * Escala);
Bottom := Trunc(ElJPG.Height * Escala);
Left := 0;
Top := 0;
END;
//Dibujamos el bitmap con el nuevo tama?o en el TImage destino
WITH QueImage.Picture.Bitmap DO
BEGIN
Width := Rectangulo.Right;
Height := Rectangulo.Bottom;
Canvas.StretchDraw(Rectangulo, ElJPG);
END;
FINALLY
ElJPG.Free;
END;
END; {De CargaJPGProporcionado}
BEGIN
CargaJPGProporcionado('UnaFoto.jpg', Image1);
END;
Escalar un bitmap por porcentaje
{ .... }
private
FUNCTION ScalePercentBmp(bitmp: TBitmap; iPercent: Integer): Boolean;
{ .... }FUNCTION TForm1.ScalePercentBmp(bitmp: TBitmap;
iPercent: Integer): Boolean;
VAR
TmpBmp: TBitmap;
ARect: TRect;
h, w: Real;
hi, wi: Integer;
BEGIN
Result := False;
TRY
TmpBmp := TBitmap.Create;
TRY
h := bitmp.Height * (iPercent / 100);
w := bitmp.Width * (iPercent / 100);
hi := StrToInt(FormatFloat('#', h)) + bitmp.Height;
wi := StrToInt(FormatFloat('#', w)) + bitmp.Width;
TmpBmp.Width := wi;
TmpBmp.Height := hi;
ARect := Rect(0, 0, wi, hi);
TmpBmp.Canvas.StretchDraw(ARect, Bitmp);
bitmp.Assign(TmpBmp);
FINALLY
TmpBmp.Free;
END;
Result := True;
EXCEPT
Result := False;
END;
END;
//ejemplo
PROCEDURE TForm1.Button1Click(Sender: TObject);
BEGIN
ScalePercentBmp(Image1.Picture.Bitmap, 33);
END;
Crear thumbnails
Autor: Roy Magne Klever
{
Here is the routine I use in my thumbnail component and I belive it is quite
fast.
A tip to gain faster loading of jpegs is to use the TJpegScale.Scale
property. You can gain a lot by using this correct.
This routine can only downscale images no upscaling is supported and you
must correctly set the dest image size. The src.image will be scaled to fit
in dest bitmap.
}PROCEDURE MakeThumbNail(src, dest: TBitmap; ThumbSize: Word);
TYPE
PRGB24 = ^TRGB24;
TRGB24 = PACKED RECORD
B: Byte;
G: Byte;
R: Byte;
END;
VAR
x, y, ix, iy: integer;
x1, x2, x3: integer;
xscale, yscale: single;
iRed, iGrn, iBlu, iRatio: Longword;
p, c1, c2, c3, c4, c5: tRGB24;
pt, pt1: pRGB24;
iSrc, iDst, s1: integer;
i, j, r, g, b, tmpY: integer;
RowDest, RowSource, RowSourceStart: integer;
w, h: integer;
dxmin, dymin: integer;
ny1, ny2, ny3: integer;
dx, dy: integer;
lutX, lutY: ARRAY OF integer;
BEGIN
IF src.PixelFormat < > pf24bit THEN src.PixelFormat := pf24bit;
IF dest.PixelFormat < > pf24bit THEN dest.PixelFormat := pf24bit;
dest.Width := ThumbSize;
dest.Height := ThumbSize;
w := ThumbSize;
h := ThumbSize;
IF (src.Width < = ThumbSize) AND (src.Height < = ThumbSize) THEN
BEGIN
dest.Assign(src);
exit;
END;
iDst := (w * 24 + 31) AND NOT 31;
iDst := iDst DIV 8; //BytesPerScanline
iSrc := (Src.Width * 24 + 31) AND NOT 31;
iSrc := iSrc DIV 8;
xscale := 1 / (w / src.Width);
yscale := 1 / (h / src.Height);
// X lookup table
SetLength(lutX, w);
x1 := 0;
x2 := trunc(xscale);
FOR x := 0 TO w - 1 DO
BEGIN
lutX[x] := x2 - x1;
x1 := x2;
x2 := trunc((x + 2) * xscale);
END;
// Y lookup table
SetLength(lutY, h);
x1 := 0;
x2 := trunc(yscale);
FOR x := 0 TO h - 1 DO
BEGIN
lutY[x] := x2 - x1;
x1 := x2;
x2 := trunc((x + 2) * yscale);
END;
dec(w);
dec(h);
RowDest := integer(Dest.Scanline[0]);
RowSourceStart := integer(Src.Scanline[0]);
RowSource := RowSourceStart;
FOR y := 0 TO h DO
BEGIN
dy := lutY[y];
x1 := 0;
x3 := 0;
FOR x := 0 TO w DO
BEGIN
dx := lutX[x];
iRed := 0;
iGrn := 0;
iBlu := 0;
RowSource := RowSourceStart;
FOR iy := 1 TO dy DO
BEGIN
pt := PRGB24(RowSource + x1);
FOR ix := 1 TO dx DO
BEGIN
iRed := iRed + pt.R;
iGrn := iGrn + pt.G;
iBlu := iBlu + pt.B;
inc(pt);
END;
RowSource := RowSource - iSrc;
END;
iRatio := 65535 DIV (dx * dy);
pt1 := PRGB24(RowDest + x3);
pt1.R := (iRed * iRatio) SHR 16;
pt1.G := (iGrn * iRatio) SHR 16;
pt1.B := (iBlu * iRatio) SHR 16;
x1 := x1 + 3 * dx;
inc(x3, 3);
END;
RowDest := RowDest - iDst;
RowSourceStart := RowSource;
END;
IF dest.Height < 3 THEN exit;
// Sharpening...
s1 := integer(dest.ScanLine[0]);
iDst := integer(dest.ScanLine[1]) - s1;
ny1 := Integer(s1);
ny2 := ny1 + iDst;
ny3 := ny2 + iDst;
FOR y := 1 TO dest.Height - 2 DO
BEGIN
FOR x := 0 TO dest.Width - 3 DO
BEGIN
x1 := x * 3;
x2 := x1 + 3;
x3 := x1 + 6;
c1 := pRGB24(ny1 + x1)^;
c2 := pRGB24(ny1 + x3)^;
c3 := pRGB24(ny2 + x2)^;
c4 := pRGB24(ny3 + x1)^;
c5 := pRGB24(ny3 + x3)^;
r := (c1.R + c2.R + (c3.R * -12) + c4.R + c5.R) DIV -8;
g := (c1.G + c2.G + (c3.G * -12) + c4.G + c5.G) DIV -8;
b := (c1.B + c2.B + (c3.B * -12) + c4.B + c5.B) DIV -8;
IF r < 0 THEN r := 0 ELSE IF r > 255 THEN r := 255;
IF g < 0 THEN g := 0 ELSE IF g > 255 THEN g := 255;
IF b < 0 THEN b := 0 ELSE IF b > 255 THEN b := 255;
pt1 := pRGB24(ny2 + x2);
pt1.R := r;
pt1.G := g;
pt1.B := b;
END;
inc(ny1, iDst);
inc(ny2, iDst);
inc(ny3, iDst);
END;
END;
PROCEDURE TForm1.Button1Click(Sender: TObject);
VAR
dest: TBitmap;
BEGIN
dest := TBitmap.Create;
TRY
MakeThumbNail(Image1.Picture.Bitmap, dest, 100);
Image2.Picture.Bitmap.Assign(dest);
FINALLY
dest.Free;
END;
END;
Encriptar un bmp
PROCEDURE EncryptBMP(CONST BMP: TBitmap; Key: Integer);
VAR
BytesPorScan: Integer;
w, h: integer;
p: pByteArray;
BEGIN
TRY
BytesPorScan := Abs(Integer(BMP.ScanLine[1]) -
Integer(BMP.ScanLine[0]));
EXCEPT
RAISE Exception.Create('Error');
END;
RandSeed := Key;
FOR h := 0 TO BMP.Height - 1 DO
BEGIN
P := BMP.ScanLine[h];
FOR w := 0 TO BytesPorScan - 1 DO
P^[w] := P^[w] XOR Random(256);
END;
END;
PROCEDURE TForm1.Button1Click(Sender: TObject);
BEGIN
EncryptBMP(Image1.Picture.Bitmap, 623);
Image1.Refresh;
END;
Cargar una imagen jpg en un bmp
VAR
bmp: tbitmap;
BEGIN
bmp := tbitmap.create;
TRY
....
Image1.Picture.loadfromfile('foto.jpg');
// Asigna el image1 -jpg- al bmp
Bmp.Assign(image1.Picture.Graphic);
bmp.Width := Image1.width;
bmp.Height := Image1.Height;
bmp.Canvas.StretchDraw(Bmp.Canvas.ClipRect, Image1.picture.graphic);
.....
// aquí se destruiría el bmp creado anteriormente
FINALLY
bmp.free;
END;
Cargar un bmp en un timage
bmp := tbitmap.create;
TRY
Image1.picture.Assign(bmp);
FINALLY
bmp.free;
END;
Leer un bitmap pixel a pixel
procedure TForm1.LeerBitmapPixelAPixel;
var
vBitMapData : TBitmapData;
vPixelColor : TAlphaColor; // Note: FireMonkey colors are different from VCL TColor
x,y : Integer;
begin
memo1.Lines.Clear;
// dump bitmap pixels
if image1.Bitmap.Map(TMapAccess.maRead, vBitMapData) then // lock bitmap and get pixels
begin
for y := 0 to trunc(image1.Bitmap.height)-1 do // loop through image lines
begin
Memo1.Lines.Add('======================');
memo1.Lines.Add('Line # ' + IntToStr(Y));
Memo1.Lines.Add('======================');
for x := 0 to trunc(image1.Bitmap.width)-1 do // loop through pixels on the line
begin
vPixelColor := vBitmapData.GetPixel(x,y); // get the pixel colour
memo1.Lines.Add( // dump pixel info to screen
'line=' + IntToStr(Y)
+ ' row=' + IntToStr(X)
+ ' Colour=' + IntToStr(vBitmapData.GetPixel(x,y))
+ ' Red=' + IntToStr (TAlphaColorRec(vPixelColor).R) // red
+ ' Green=' + IntToStr (TAlphaColorRec(vPixelColor).G) // blue
+ ' Blue=' + IntToStr (TAlphaColorRec(vPixelColor).B) // green
)
end;
end;
image1.Bitmap.Unmap(vBitMapData); // unlock the bitmap
end;
end;
Modificar un pixel de un bitmap
procedure TForm1.EscribirEnUnPixelDeUnBitmap;
// example of setting a single pixel in a TImage bitmap.
// the image must already be loaded in the TImage
var
vBitMapData : TBitmapData;
vPixelColor : TAlphaColor; // note: FireMonkey colors are different from VCL TColor
begin
// lock and get the bitmap pixels
if image1.Bitmap.Map(TMapAccess.maWrite, vBitMapData) then
begin
vPixelColor := TAlphaColorRec.Blue; // determine colour to use
vBitmapData.SetPixel(10,20, vPixelColor); // set the pixel colour at x:10, y:20
image1.Bitmap.Unmap(vBitMapData); // unlock the bitmap
end;
end;
Cambiar el color del canal Alpha de un Bitmap
PROCEDURE SetAlphaBitmap(Dest: TBitmap; Color: TColor; Alpha: Byte);
TYPE
TRGB32 = PACKED RECORD
B, G, R, A: Byte;
END;
PRGBArray32 = ^TRGBArray32;
TRGBArray32 = ARRAY [0 .. 0] OF TRGB32;
VAR
x, y: Integer;
Line: PRGBArray32;
ColorRGB: Longint;
Red, Green, Blue: Byte;
BEGIN
IF Dest.PixelFormat <> pf32bit THEN
exit;
ColorRGB := ColorToRGB(Color);
Red := GetRValue(ColorRGB);
Green := GetGValue(ColorRGB);
Blue := GetBValue(ColorRGB);
FOR y := 0 TO Dest.Height - 1 DO
BEGIN
Line := PRGBArray32(Dest.ScanLine[y]);
FOR x := 0 TO Dest.Width - 1 DO
BEGIN
WITH Line[x] DO
BEGIN
IF (R = Red) AND (G = Green) AND (B = Blue) THEN
A := Alpha;
END;
END;
END;
END;
Convertir imagen png en bmp
procedure tForm1.PngFileToBitmap(Src,Dest:String);
var
bmp:tbitmap;
png:tPngImage;
begin
bmp := tbitmap.Create;
png := tPngImage.Create;
try
png.LoadFromFile(src);
bmp.Assign(png);
bmp.saveToFile(dest);
finally
bmp.free;
png.Free;
end;
end;
Convertir imagen bmp en png
procedure tForm1.BMPFileToPNG(Src,Dest:String);
var
bmp:tbitmap;
png:tPngImage;
begin
bmp := tbitmap.Create;
png := tPngImage.Create;
try
bmp.LoadFromFile(src);
png.Assign(bmp);
png.saveToFile(dest);
finally
bmp.free;
png.Free;
end;
end;
Libros para saber más:
Tratamiento digital de la imagen (Anaya)
Tratamiento digital de imágenes fotográficas
Tratamiento digital de la imagen con Adobe Photoshop
Astrofotografía con cámaras digitales
Edición de medios digitales con software libre (Anaya)
No hay comentarios:
Publicar un comentario