4 respuestas en este tema

[escafandra]

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

procedure DrawTextTexture(Text: String; Canvas: TCanvas; X, Y: integer; Texture: TBitmap);
var
  Bitmap: TBitmap;
begin
  Bitmap:= TBitmap.Create;
 
  SetBkMode(Canvas.Handle, TRANSPARENT);
  Canvas.TextOut(20, 20, PCHAR(Text));
 
  // Invierto la imagen del texto
  Canvas.CopyMode:= cmDstInvert;
  Canvas.Draw(0,0,Bitmap);
 
  // AND con la textura
  Canvas.CopyMode:= cmSrcPaint;
  Canvas.Draw(0,0,Texture);
 
  Bitmap.Free;
end;

La forma de usarlo:

delphi

procedure TForm1.Button3Click(Sender: TObject);
var
  Texture: TBitmap;
begin
  // Tomamos una fuente lo suficientemente grande 
  Image1.Canvas.Font.Name:= 'Arial Black';
  Image1.Canvas.Font.Size:= 90;
 
  // Cargamos la Textura
  Texture:= TBitmap.Create;
  Texture.LoadFromFile('madera.bmp');
 
  // Dibujamos el texto con su textura de relleno
  DrawTextTexture('TEXTO', Image1.Canvas, 20, 20, Texture);
 
  Texture.Free;
end;

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



Saludos.

[egostar]

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

 

Saludos

[FerCastro]

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

[escafandra]

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

procedure DrawTextTexture2(Text: PCHAR; X, Y: integer; DC: HDC; Texture: HBitmap);
var
  hMask, hTexture: HBITMAP ;
  dcTexture, dcMask: HDC;
  Bmp: TagBITMAP;
  Font: HFONT;
  Brush: HBRUSH;
  OldColor: COLORREF;
  R: TRect;
begin
  Font:= GetCurrentObject(DC, OBJ_FONT);
  Brush:= CreatePatternBrush(Texture);
  GetObject(GetCurrentObject(DC, OBJ_BITMAP), sizeof(BITMAP), @Bmp);
  hMask := CreateBitmap(Bmp.bmWidth, Bmp.bmHeight, 1, 32, nil);
  hTexture := CreateBitmap(Bmp.bmWidth, Bmp.bmHeight, 1, 32, nil);
  dcTexture := CreateCompatibleDC(0);
  dcMask := CreateCompatibleDC(0);
 
  // Relleno la textura
  SelectObject(dcTexture, hTexture);
  SelectObject(dcMask, hMask);
  R.Left:= 0; R.Top:= 0; R.Right:= Bmp.bmWidth; R.Bottom:= Bmp.bmHeight;
  FillRect(dcTexture, R, Brush);
 
  // Pinto el texto en blanco en estino
  SetBkMode(DC, TRANSPARENT);
  OldColor:= SetTextColor(DC, $FFFFFF);
  TextOut(DC, 20, 20, Text, lstrlen(Text));
  SetTextColor(DC, OldColor);
 
  // Pinto el texto en negro en mask
  SelectObject(dcMask, Font);
  BitBlt(dcMask, 0, 0, Bmp.bmWidth, Bmp.bmHeight, DC, 0, 0, WHITENESS);
  SetBkMode(dcMask, TRANSPARENT);
  TextOut(dcMask, 20, 20, Text, lstrlen(Text));
 
  // Paso la textura a mask
  BitBlt(dcMask, 0, 0, Bmp.bmWidth, Bmp.bmHeight, dcTexture, 0, 0, SRCPAINT);
  // Hago AND entre destino y mask
  BitBlt(DC, 0, 0, Bmp.bmWidth, Bmp.bmHeight, dcMask, 0, 0, SRCAND);
 
  // Liberar los HDC, la Mascara y la textura
  DeleteDC(dcTexture);
  DeleteDC(dcMask);
  DeleteObject(hMask);
  DeleteObject(hTexture);
  DeleteObject(Brush);
end;

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

 

Un ejemplo de uso:

delphi

procedure TForm1.Button2Click(Sender: TObject);
var
  Texture: TBitmap;
begin
  // La fuente...
  Image1.Canvas.Font.Name:= 'Arial Black';
  Image1.Canvas.Font.Size:= 90;
  Image1.Picture.Bitmap.PixelFormat := pf32bit;
  Image3.Canvas.Font.Assign(Image1.Canvas.Font);
 
  // La textura...
  Texture:= TBitmap.Create;
  Texture.LoadFromFile('Marmol2.bmp');
  Texture.PixelFormat := pf32bit;
 
  // Dibujando el texto...
  DrawTextTexture2('TEXTO', 20, 20, Image1.Canvas.Handle, Texture.Handle);
  DrawTextTexture2('TEXTO', 20, 20, Image3.Canvas.Handle, Texture.Handle);
 
  Texture.Free;
  Invalidate;
end;

 Textura.jpg   113,92KB   3 descargas

 

 

 

Saludos.

[sir.dev.a.lot]

TadvSmoothLabel

 

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

 

Saludos!