Real Font Metrics Retreive

[Aldo Cavini]

the following function retreives the exact ascent, descent and maximum ascent for a given font. it works on a monochorome di bitmap - max 100 rows (ascent) + 50 rows (descent). for any replies, please use the http://www.powerbasic.com/support/pb...ead.php?t=3617 forum.

' -------------------------------------------------------------------------------------------------
' - retreive real font metrics - by aldo cavini - april 19, 2001 ----------------------------------
' -------------------------------------------------------------------------------------------------

#compile exe
#dim     all
#include "win32api.inc"

type realfonttype
  rfdescent   as long   ' maximum number of rows below the baseline              (complete char-set)
  rfascent    as long   ' number of rows below the baseline, standard upper-case letters (like a, b)
  rfmaxascent as long   ' maximum rows used with accents, umlauts, rings, etc.   (complete char-set)
end type

' -------------------------------------------------------------------------------------------------

function realfontmeasure( hfont as long, realf as realfonttype ) as long
  
local bminfo     as bitmapinfo
local hdc        as long
local hbm        as long
local dat        as dword ptr
local i          as long
                                        
  bminfo.bmiheader.bisize          = sizeof( bminfo.bmiheader )
  bminfo.bmiheader.biwidth         = 32
  bminfo.bmiheader.biheight        = 150
  bminfo.bmiheader.biplanes        = 1
  bminfo.bmiheader.bibitcount      = 1
  bminfo.bmiheader.bicompression   = 0

  hbm = createdibsection( %null, bminfo, %dib_rgb_colors, varptr( dat ), byval %null, byval %null )
  hdc = createcompatibledc( %null )
  selectobject hdc, hbm

  selectobject hdc, hfont
  settextalign hdc, %ta_baseline or %ta_left
  setbkmode    hdc, %transparent
  settextcolor hdc, %white
  setbkcolor   hdc, %black
  
  for i = asc( "a" ) to asc( "z" )
    textout hdc, 0, 100, chr$( i ), 1
  next i
  for i = 99 to 1 step -1
    if @dat[ 50 + i ] <> 0 then
      exit for
    end if
  next
  realf.rfascent = i
  for i = 32 to 255
    textout hdc, 0, 100, chr$( i ), 1
  next i
  for i = 99 to 1 step -1
    if @dat[ 50 + i ] <> 0 then
      exit for
    end if
  next
  realf.rfmaxascent = i
  for i = -49 to -1
    if @dat[ 50 + i ] <> 0 then
      exit for
    end if
  next i
  realf.rfdescent = - i

  deletedc     hdc
  deleteobject hbm

end function

------------------