Club Delphi  
    FTP   CCD     Buscar   Trucos   Trabajo   Foros

Retroceder   Foros Club Delphi > Otros temas > Trucos
Registrarse FAQ Miembros Calendario Guía de estilo Buscar Temas de Hoy Marcar Foros Como Leídos

Los mejores trucos

Respuesta
 
Herramientas Buscar en Tema Desplegado
  #1  
Antiguo 16-01-2022
guspx guspx is offline
Miembro
 
Registrado: jun 2019
Posts: 17
Poder: 0
guspx Va por buen camino
Corregir métrica errónea de familias de tipos de letra

Hola, seguramente habréis ya comprobado muchos que hay algunos tipos de letra, p. ej. Gabriola y Cambria Math, que devuelven información aparentemente errónea en GetTextMetrics. Es solo aparentemente porque en realidad es correcto, lo que ocurre es que dejan un gran espacio arriba (tm.tmAscent) y abajo (tm.tmDescent) en blanco. Entonces no vale usar tm.tmHeight para saber donde imprimir una nueva línea.
Con GdiPlus existe un valor para cada familia, LineSpacing. Si se usa este valor el resultado es el mismo que con tm.tmHeight. Pero GdiPlus también te devuelve un ascent y descent (GetCellAscent y GetCellDescent) que pasados a píxeles devuelven un valor correcto. Usando una combinación de gdiplus y gdi he pergeñado esta función que aparentemente funciona con todos los tipos de letra, incluídos los dos citados, se basa en imprimir el texto en un hdc auxiliar y después quitarle el ascent y descent que parecen estar en blanco, que aquí he supuesto que podría ser la diferencia entre el ascent que devuelve GetTextMetrics y el que devuelve gdiplus y que parece ser una suposición afortunada. La función devuelve el alto correcto para que se use en la siguiente línea. Si simplemente se usa el mismo resultado (ascent + descent) con la función normal TextOut se borra parte del contenido de la línea anterior. El caso es que la publico porque parece funcionar, Gabriola es un tipo de letra muy artístico. Saludos. (Buscar en goog "bilsen gdiplus")

Código Delphi [-]
Use gdiplus;

function GdiPlusTextOut(Dc: HDC; x, y: Integer; stext: string): Integer;
var
  TempDc: HDC;
  oldbit, hbit: HBITMAP;
  fam: IgpFontFamily;
  f: IgpFont;
  tm: TTextMetric;
  oldfont, newfont: HFONT;
  lf: TLogFont;
  graphics: IgpGraphics;
  r: TGpRectF;
  w, h: Integer;
  curalign, curstretch, asc, desc: Integer;
begin
  Result:= 0;
  oldfont:= GetCurrentObject(Dc, OBJ_FONT);
  if oldfont = 0 then
    exit;
  if GetObject(oldfont, sizeof(TLogFont), @lf) = 0 then
    exit;
  newfont:= CreateFontIndirect(lf);
  if newfont = 0 then
    exit;
  TempDc:= CreateCompatibleDC(DC);
  fam:= tgpfontfamily.Create(lf.lfFaceName);
  graphics:= TgpGraphics.Create(Dc);
  f:= TGpFont.Create(Dc, newfont);
  GetTextMetrics(Dc, tm);
  curstretch:= SetStretchBltMode(Dc, COLORONCOLOR);
  try
    r:= graphics.MeasureString(stext, f, TGpPointF.Create(X, Y));
    w:= Ceil(r.Width);
    h:= tm.tmHeight;
    hbit:= CreateCompatibleBitmap(Dc, w, h);
    oldbit:= SelectObject(TempDc, hbit);
    oldfont:= SelectObject(TempDc, newfont);
    curalign:= SetTextAlign(TempDC, TA_LEFT or TA_TOP);
    try
      PatBlt(TempDc, 0, 0, w, h, WHITENESS);
      SetTextColor(TempDc, GetTextColor(Dc));
      SetBkMode(TempDc, TRANSPARENT);
      TextOut(TempDc, 0, 0, PChar(stext), Length(stext));
      asc:= Round(F.Size * fam.GetCellAscent(fontstyleregular) /
         fam.GetEmHeight(FontStyleRegular));  // valor en píxeles
      desc:= Round(F.Size * fam.GetCellDescent(fontstyleregular) /
         fam.GetEmHeight(FontStyleRegular));  // valor en píxeles
      TransparentBlt(Dc, x, y, w, asc + desc, TempDc, 0, tm.tmAscent - asc,
        w, asc + desc, $FFFFFF);
      Result:= asc + desc;
    finally
      SetTextAlign(TempDc, curalign);
      SelectObject(TempDC, oldfont);
      DeleteObject(newfont);
      SelectObject(TempDc, oldbit);
      DeleteObject(hbit);
    end;
  finally
    graphics:= nil;
    f:= nil;
    fam:= nil;
    SetStretchBltMode(Dc, curstretch);
    DeleteDC(TempDc);
  end;
end;

Y el uso:

Código Delphi [-]
procedure TForm1.FormPaint(Sender: TObject);
var
  ascdesc: Integer;
begin
  with canvas do
  begin
    font.Name:= 'Gabriola';
    font.Size:= 18;
    ascdesc:= GdiplusTextOut(handle, 0, 0, 'Hola');
    GdiplusTextOut(handle, 0, ascdesc, 'mundo');
  end;
end;

Última edición por Casimiro Notevi fecha: 16-01-2022 a las 20:19:00.
Responder Con Cita
  #2  
Antiguo 16-01-2022
guspx guspx is offline
Miembro
 
Registrado: jun 2019
Posts: 17
Poder: 0
guspx Va por buen camino
Corrección

Para incluir si la letra es negrita o itálica:

Código Delphi [-]
function GdiPlusTextOut(Dc: HDC; x, y: Integer; stext: string): Integer;
var
  TempDc: HDC;
  oldbit, hbit: HBITMAP;
  fam: IgpFontFamily;
  f: IgpFont;
  tm: TTextMetric;
  oldfont, newfont: HFONT;
  lf: TLogFont;
  graphics: IgpGraphics;
  r: TGpRectF;
  w, h: Integer;
  curalign, curstretch, asc, desc: Integer;
  style: TgpFontStyle;
begin
  Result:= 0;
  oldfont:= GetCurrentObject(Dc, OBJ_FONT);
  if oldfont = 0 then
    exit;
  if GetObject(oldfont, sizeof(TLogFont), @lf) = 0 then
    exit;
  newfont:= CreateFontIndirect(lf);
  if newfont = 0 then
    exit;
  style:= [];
  if lf.lfWeight = FW_BOLD then
    style:= style + [FontStyleBold];
  if lf.lfItalic <> 0 then
    style:= style + [FontStyleItalic];
  if lf.lfUnderline <> 0 then
    style:= style + [FontStyleUnderline];
  TempDc:= CreateCompatibleDC(DC);
  fam:= tgpfontfamily.Create(lf.lfFaceName);
  graphics:= TgpGraphics.Create(Dc);
  f:= TGpFont.Create(Dc, newfont);
  GetTextMetrics(Dc, tm);
  curstretch:= SetStretchBltMode(Dc, COLORONCOLOR);
  try
    r:= graphics.MeasureString(stext, f, TGpPointF.Create(X, Y));
    w:= Ceil(r.Width);
    h:= tm.tmHeight;
    hbit:= CreateCompatibleBitmap(Dc, w, h);
    oldbit:= SelectObject(TempDc, hbit);
    oldfont:= SelectObject(TempDc, newfont);
    curalign:= SetTextAlign(TempDC, TA_LEFT or TA_TOP);
    try
      PatBlt(TempDc, 0, 0, w, h, WHITENESS);
      SetTextColor(TempDc, GetTextColor(Dc));
      SetBkMode(TempDc, TRANSPARENT);
      TextOut(TempDc, 0, 0, PChar(stext), Length(stext));
      asc:= Round(F.Size * fam.GetCellAscent(style) /
         fam.GetEmHeight(style));
      desc:= Round(F.Size * fam.GetCellDescent(style) /
         fam.GetEmHeight(style));
      TransparentBlt(Dc, x, y, w, asc + desc, TempDc, 0, tm.tmAscent - asc,
        w, asc + desc, $FFFFFF);
      Result:= asc + desc;
    finally
      SetTextAlign(TempDc, curalign);
      SelectObject(TempDC, oldfont);
      DeleteObject(newfont);
      SelectObject(TempDc, oldbit);
      DeleteObject(hbit);
    end;
  finally
    graphics:= nil;
    f:= nil;
    fam:= nil;
    SetStretchBltMode(Dc, curstretch);
    DeleteDC(TempDc);
  end;
end;

Última edición por Casimiro Notevi fecha: 16-01-2022 a las 20:19:28.
Responder Con Cita
  #3  
Antiguo 16-01-2022
Avatar de Casimiro Notevi
Casimiro Notevi Casimiro Notevi is offline
Moderador
 
Registrado: sep 2004
Ubicación: En algún lugar.
Posts: 32.021
Poder: 10
Casimiro Notevi Tiene un aura espectacularCasimiro Notevi Tiene un aura espectacular
Gracias por el aporte
Responder Con Cita
  #4  
Antiguo 16-01-2022
guspx guspx is offline
Miembro
 
Registrado: jun 2019
Posts: 17
Poder: 0
guspx Va por buen camino
He podido comprobar que hay algunas fuentes que no soporta, como las que comienzan por @. También que gdi plus no soporta tipos de letra no true type, al parecer, pero quitando esas con @, la mayoría sí que las soporta.
Responder Con Cita
  #5  
Antiguo 17-01-2022
guspx guspx is offline
Miembro
 
Registrado: jun 2019
Posts: 17
Poder: 0
guspx Va por buen camino
Perdón, última edición. Cambiar:

Código Delphi [-]
f:= TGpFont.Create(Dc, newfont);

Por:

Código Delphi [-]
f:= TGpFont.Create(fam, -lf.lfHeight * 72 div GetDeviceCaps(DC, LOGPIXELSY), style, UnitPixel);

Esto resuelve algunos problemas, siempre que fam no sea nil, claro. Lo que sucede con algunas fuentes en las que es posible detectarlo antes de usarla, aunque es algo complicado, lo diré muy sucintamente. Se basa en llamar a EnumFontFamiliesEx y en la función callback EnumFontFamExProc detectar que en la estructura PNEWTEXTMETRICEX, el bit 21 del elemento ntmFlags sea 1. Ver la página de microsoft sobre "NEWTEXTMETRICA". Cuando la fuente no tiene una fontsignature válida, gdiplus no la acepta.

Última edición por Casimiro Notevi fecha: 17-01-2022 a las 12:31:17.
Responder Con Cita
  #6  
Antiguo 17-01-2022
Avatar de ElKurgan
[ElKurgan] ElKurgan is offline
Miembro Premium
 
Registrado: nov 2005
Posts: 1.232
Poder: 20
ElKurgan Va camino a la fama
Thumbs up

Gracias por la información

Saludos
Responder Con Cita
  #7  
Antiguo 17-01-2022
guspx guspx is offline
Miembro
 
Registrado: jun 2019
Posts: 17
Poder: 0
guspx Va por buen camino
Perdón, siempre cometo el error de precipitarme en publicar algo sin comprobarlo bien.

En realidad la TGpFont debe ser creada así:

Código Delphi [-]
      f:= TGpFont.Create(fam, -lf.lfHeight, style, UnitWorld);

Última edición por Casimiro Notevi fecha: 17-01-2022 a las 12:31:33.
Responder Con Cita
  #8  
Antiguo 17-01-2022
guspx guspx is offline
Miembro
 
Registrado: jun 2019
Posts: 17
Poder: 0
guspx Va por buen camino
Y hay veces en que TransparentBlt falla, para corregir esto:

Código Delphi [-]
if not TransparentBlt(Dc, x, y, w, Min(h, asc + desc),
            TempDc, 0, Max(0, tm.tmAscent - asc), w,
            Min(h, asc + desc), $FFFFFF) then
  exit;
Result:= MIn(h, asc + desc);

Cuando la funciòn devuelva 0 porque hay algún fallo se puede llamar a TextOut normal.

Última edición por Casimiro Notevi fecha: 17-01-2022 a las 12:31:57.
Responder Con Cita
Respuesta


Herramientas Buscar en Tema
Buscar en Tema:

Búsqueda Avanzada
Desplegado

Normas de Publicación
no Puedes crear nuevos temas
no Puedes responder a temas
no Puedes adjuntar archivos
no Puedes editar tus mensajes

El código vB está habilitado
Las caritas están habilitado
Código [IMG] está habilitado
Código HTML está deshabilitado
Saltar a Foro

Temas Similares
Tema Autor Foro Respuestas Último mensaje
Listado de tipos de letra jandro Varios 5 18-11-2009 00:49:46
TextBox escribir automaticamente letra por letra? Ejemplo Dentro! Gattaca Varios 2 21-03-2009 18:41:32
Relacion familias y articulos Espartaco SQL 7 20-06-2008 10:31:54
Codigos para impresoras: tipos de letra, orientacion hoja, etc Meneleo Impresión 1 11-03-2007 08:40:29
Familias de productos con TTreeView thunor Varios 0 10-08-2003 02:51:01


La franja horaria es GMT +2. Ahora son las 22:18:58.


Powered by vBulletin® Version 3.6.8
Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Traducción al castellano por el equipo de moderadores del Club Delphi
Copyright 1996-2007 Club Delphi