Corregir métrica errónea de familias de tipos de letra

[guspx]

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;

[guspx]

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;

[Casimiro Notevi]

Gracias por el aporte

[guspx]

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.

[guspx]

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.

[[ElKurgan]]

Gracias por la información

Saludos

[guspx]

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);

[guspx]

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.