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;