Componente para manipulacion de imagenes en Delphi

Aquí tienen un impresionante componente llamado " TEffects " para manipulación de imágenes en Delphi.
Con él se pueden realizar efectos que se ven en programas de retoque fotográfico o edición de imágenes como Corel Paintshop o Adobe Photoshop.

Notas de instalación
El uso de los ejemplos necesita previamente la instalación de las siguientes unit.
que deben ser instaladas en el siguiente orden
  1. MemUtils
  2. ExactTimer
  3. Waiter
  4. GrayBitmap
  5. Shape
  6. Effects
  7. GraphUtils
  8. FunThings



Entre otras cosas se pueden implementar los siguientes temas:

(Copiado de la página del autor)

Adjusts color information
Inverts colors
Filters colors
Rotate image to any degree
Adjusts channel colors
Fills channels
Implements transparency effect
Implements blur effect
Implements rough blur effect
Implements pixelization effect
Uploads and extracts a data of any type into a single image at binary level (cryptography)

A few fun things are in TGraphUtils and TFunThings units. These units include:

TBitmapConvertor is intended for conversions between TBitmap class and TSmallBitmap structure (TSmallBitmap is type of dynamic array that represents 32 bit image of any size)
TCustomTextConvertor is abstract class that contains base code for conversion from bitmap into colored text
TCustomTextDrawer is one more abstract class with a code for drawing of colored text on a display device context
TTextConvertor converts image into html document
TTextDrawer is descendant of TCustomTextDrawer class
TDesktopDrawer is descendant of TCustomTextDrawer class which draws text directly on the desktop.

Link de descarga del Componente:

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


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;

Relacionados:

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)