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

[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 Noteví]

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.