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


No hay comentarios:

Publicar un comentario