Trucos sobre imágenes en Delphi

ÍNDICE
- 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


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;









Relacionados:

Ejemplos de rutinas gráficas con Firemonkey

Reconocimiento de caras

OCR con Tesseract

OCR simplificado

OCR con Delphi


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