Ir al contenido


Foto

Dibujar un texto con textura


  • Por favor identifícate para responder
4 respuestas en este tema

#1 escafandra

escafandra

    Advanced Member

  • Administrador
  • 4.107 mensajes
  • LocationMadrid - España

Escrito 04 septiembre 2016 - 05:33

Este truco proviene de esta pregunta: como poner textura a una imagen Se trata de poner textura a un texto usando un Bitmap que lo cubra
 
En principio necesita un Canvas en blanco donde dibujar, que puede ser el de un TImage, Un Bitmap de textura tan grande como el texto que queramos poner y un texto.
 

delphi
  1. procedure DrawTextTexture(Text: String; Canvas: TCanvas; X, Y: integer; Texture: TBitmap);
  2. var
  3.   Bitmap: TBitmap;
  4. begin
  5.   Bitmap:= TBitmap.Create;
  6.  
  7.   SetBkMode(Canvas.Handle, TRANSPARENT);
  8.   Canvas.TextOut(20, 20, PCHAR(Text));
  9.  
  10.   // Invierto la imagen del texto
  11.   Canvas.CopyMode:= cmDstInvert;
  12.   Canvas.Draw(0,0,Bitmap);
  13.  
  14.   // AND con la textura
  15.   Canvas.CopyMode:= cmSrcPaint;
  16.   Canvas.Draw(0,0,Texture);
  17.  
  18.   Bitmap.Free;
  19. end;

La forma de usarlo:

delphi
  1. procedure TForm1.Button3Click(Sender: TObject);
  2. var
  3. Texture: TBitmap;
  4. begin
  5. // Tomamos una fuente lo suficientemente grande
  6. Image1.Canvas.Font.Name:= 'Arial Black';
  7. Image1.Canvas.Font.Size:= 90;
  8.  
  9. // Cargamos la Textura
  10. Texture:= TBitmap.Create;
  11. Texture.LoadFromFile('madera.bmp');
  12.  
  13. // Dibujamos el texto con su textura de relleno
  14. DrawTextTexture('TEXTO', Image1.Canvas, 20, 20, Texture);
  15.  
  16. Texture.Free;
  17. end;

El resultado será algo como esto:
Archivo adjunto  Texturas.JPG   42,57KB   5 descargas



Saludos.
  • 4

#2 egostar

egostar

    missing my father, I love my mother.

  • Administrador
  • 14.446 mensajes
  • LocationMéxico

Escrito 04 septiembre 2016 - 06:27

Al principio pensé que era algo como los captchas, pero no. Me gusta el efecto. (y)

 

Saludos


  • 0

#3 FerCastro

FerCastro

    Advanced Member

  • Miembro Platino
  • PipPipPip
  • 636 mensajes
  • LocationCiudad de México

Escrito 05 septiembre 2016 - 10:13

Ego, en verdad que yo tb pensè lo mismo, pero se ve super super bien el efecto.


  • 0

#4 escafandra

escafandra

    Advanced Member

  • Administrador
  • 4.107 mensajes
  • LocationMadrid - España

Escrito 08 septiembre 2016 - 09:28

Para hacer la función redonda, la he modificado, ahora pinta sobre una imagen previa que no tiene porqué ser blanca y usa una textura que no tiene porqué ser del tamaño de la imagen, el truco es crear un HBRUSH con el bitmap textura.

Esta vez me he ido a bajo nivel con la API GDI.


delphi
  1. procedure DrawTextTexture2(Text: PCHAR; X, Y: integer; DC: HDC; Texture: HBitmap);
  2. var
  3. hMask, hTexture: HBITMAP ;
  4. dcTexture, dcMask: HDC;
  5. Bmp: TagBITMAP;
  6. Font: HFONT;
  7. Brush: HBRUSH;
  8. OldColor: COLORREF;
  9. R: TRect;
  10. begin
  11. Font:= GetCurrentObject(DC, OBJ_FONT);
  12. Brush:= CreatePatternBrush(Texture);
  13. GetObject(GetCurrentObject(DC, OBJ_BITMAP), sizeof(BITMAP), @Bmp);
  14. hMask := CreateBitmap(Bmp.bmWidth, Bmp.bmHeight, 1, 32, nil);
  15. hTexture := CreateBitmap(Bmp.bmWidth, Bmp.bmHeight, 1, 32, nil);
  16. dcTexture := CreateCompatibleDC(0);
  17. dcMask := CreateCompatibleDC(0);
  18.  
  19. // Relleno la textura
  20. SelectObject(dcTexture, hTexture);
  21. SelectObject(dcMask, hMask);
  22. R.Left:= 0; R.Top:= 0; R.Right:= Bmp.bmWidth; R.Bottom:= Bmp.bmHeight;
  23. FillRect(dcTexture, R, Brush);
  24.  
  25. // Pinto el texto en blanco en estino
  26. SetBkMode(DC, TRANSPARENT);
  27. OldColor:= SetTextColor(DC, $FFFFFF);
  28. TextOut(DC, 20, 20, Text, lstrlen(Text));
  29. SetTextColor(DC, OldColor);
  30.  
  31. // Pinto el texto en negro en mask
  32. SelectObject(dcMask, Font);
  33. BitBlt(dcMask, 0, 0, Bmp.bmWidth, Bmp.bmHeight, DC, 0, 0, WHITENESS);
  34. SetBkMode(dcMask, TRANSPARENT);
  35. TextOut(dcMask, 20, 20, Text, lstrlen(Text));
  36.  
  37. // Paso la textura a mask
  38. BitBlt(dcMask, 0, 0, Bmp.bmWidth, Bmp.bmHeight, dcTexture, 0, 0, SRCPAINT);
  39. // Hago AND entre destino y mask
  40. BitBlt(DC, 0, 0, Bmp.bmWidth, Bmp.bmHeight, dcMask, 0, 0, SRCAND);
  41.  
  42. // Liberar los HDC, la Mascara y la textura
  43. DeleteDC(dcTexture);
  44. DeleteDC(dcMask);
  45. DeleteObject(hMask);
  46. DeleteObject(hTexture);
  47. DeleteObject(Brush);
  48. end;

Ahora ya podemos escribir un texto con textura sobre cualquier imagen.

 

Un ejemplo de uso:


delphi
  1. procedure TForm1.Button2Click(Sender: TObject);
  2. var
  3. Texture: TBitmap;
  4. begin
  5. // La fuente...
  6. Image1.Canvas.Font.Name:= 'Arial Black';
  7. Image1.Canvas.Font.Size:= 90;
  8. Image1.Picture.Bitmap.PixelFormat := pf32bit;
  9. Image3.Canvas.Font.Assign(Image1.Canvas.Font);
  10.  
  11. // La textura...
  12. Texture:= TBitmap.Create;
  13. Texture.LoadFromFile('Marmol2.bmp');
  14. Texture.PixelFormat := pf32bit;
  15.  
  16. // Dibujando el texto...
  17. DrawTextTexture2('TEXTO', 20, 20, Image1.Canvas.Handle, Texture.Handle);
  18. DrawTextTexture2('TEXTO', 20, 20, Image3.Canvas.Handle, Texture.Handle);
  19.  
  20. Texture.Free;
  21. Invalidate;
  22. end;

Archivo adjunto  Textura.jpg   113,92KB   3 descargas

 

 

 

Saludos.


  • 2

#5 sir.dev.a.lot

sir.dev.a.lot

    Advanced Member

  • Miembros
  • PipPipPip
  • 545 mensajes
  • Location127.0.0.1

Escrito 25 diciembre 2016 - 12:24

TadvSmoothLabel

 

http://www.tmssoftwa...vsmoothlabel.asp.

 

Saludos!


  • 1




IP.Board spam blocked by CleanTalk.