Get Textbox Font Height

[dw85745]

Can some please explain what I'm doing wrong.
I set the textbox font to "Tahoma", Fontsize = 9
and IMHO TEXTMETRICS should return that same value BUT does NOT??

Private Sub GetFontHeight()

    Dim hDC As Long
    Dim hWnd As Long
    
   'Individual Font Variables
   Dim mymetrics As TEXTMETRIC
   Dim savey As Single
   Dim InternalLeading As Single
   Dim Ascent As Single
   Dim Descent As Single
   Dim ExternalLeading As Single
   Dim txtHeight As Integer
   Dim txtHeight1 As Integer
   Dim convert As Long
   Dim convert1 As Long
   
   '--------------------------------
    
    Me.ScaleMode = vbPixels     'Form in Pixels
    
    With Me.Text1
         .FontName = "Tahoma"
         .FontSize = 9
         
          hWnd = .hWnd
    End With

    hDC = GetDC(hWnd)

   '-----------------------
   'Get Font Part Details Using API
   '------------------------
   GetTextMetrics hDC, mymetrics
   InternalLeading = mymetrics.tmInternalLeading
   Ascent = mymetrics.tmAscent
   Descent = mymetrics.tmDescent
   ExternalLeading = mymetrics.tmExternalLeading
   
   txtHeight = Ascent + Descent
   txtHeight1 = Ascent + Descent - InternalLeading
   

End Sub

[dw85745]

Bump --- NO ONE?

[VBClassicRocks]

Font size is not the same as text height

 Font.Name = "Tahoma"
 Font.Size = 9
 ScaleMode = vbPixels
 Debug.Print Font.Size, TextHeight("")

[dw85745]

Thanks for responding. As you point out:

Debug.Print Font.Size, TextHeight("")

That throws another question into the mix ?

For a Font.Size of 9, and converting it to pixels (TEXTMETRIC) and back to points I end up with 13 (Font.Size 9.75) instead of 12 (Font.Size 9.0).

This was done by Using GDI (TEXTMETRIC) and converting the result back to Font.Size
Microsoft is doing some type of Rounding or Truncating when they convert GDI pixels to VB Font.Size.
Haven't played with TextHeight yet, but based on the value of TextHeight in your example, it appears to be returning the TOTAL available
space where the font can reside which would be InternalLeading + Ascent + Descent + ExternalLeading.

[dw85745]

Unless I'm doing something wrong (always a possibility) it appears that TEXTMETRIC does NOT return the correct values (to compute the font height) for VB controls -- other than for a Form and a Picturebox (Note: both a Form and Picturebox have Scale properties. Whether this is significant is unknown.)

Using the posted code (in the original post) if one deletes With Me.Text1 and substitutes just With Me -- or -- With Me.Picture1 the correct value is returned. For All other controls, TEXTMETRIC consistently returns the "same wrong value".

Can anyone explain why this occurs???

[dw85745]

Bump

[westconn1]

when you set the font.size, is the same value returned?
the sizes of font are not always maintained by controls, to test try like

For i = 1 To 100
    Text1.Font.Size = i
    Debug.Print Text1.Font.Size
Next

[dw85745]

westconn1: Thanks for responding

Got It:
It APPEARS that ALL controls (except Form and Picturebox) create their Fonts when they gain Focus.
and destroy them when the control looses focus. Hence the Font does Not exist on the controls device context,
so the information is not avaialbe without reinstalling the Font on the DC..

Here's an example:

   
Private Sub GetFontHeight()

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

    Dim hDC As Long
    Dim hWnd As Long
    Dim strFontName As String
    Dim lngFontSize As Long
    
   'Individual Font Variables
   Dim mymetrics As TEXTMETRIC
   Dim InternalLeading As Single
   Dim Ascent As Single
   Dim Descent As Single
   Dim ExternalLeading As Single
   Dim iHeight As Integer
   Dim VerifyFSizePoints As Single
   Dim VerifyHeightPixels As Integer
   
   '********
   'STARTUP
   '********
   '------------------------------
   'Get the New Font Data
   '---------------------------
   strFontName = "Tahoma"
   lngFontSize = 48
   
    '--------------------------------------
    'Get the Controls Device Context
    '--------------------------------------
    hWnd = Me.Text1.hWnd
    hDC = GetWindowDC(hWnd)
'    hDC = GetDC(hWnd)                   '<Alternative

   '--------------------------------------------------------
   'Install the New Font Information on the Device
   '--------------------------------------------------------
   Call fCreateFontIndirect(hDC, strFontName, lngFontSize)               'My Simplied Test Function
   
   '------------------------------------------
   'Assign the New Font to the Control
   '------------------------------------------
   Me.Text1.Font.Name = strFontName
   Me.Text1.Font.Size = lngFontSize
   
    
   '********
   'MAIN
   '********
   '-----------------------
   'Get Font Part Details of the Newly Assigned Font
   '------------------------
   GetTextMetrics hDC, mymetrics
   InternalLeading = mymetrics.tmInternalLeading
   Ascent = mymetrics.tmAscent
   Descent = mymetrics.tmDescent
   ExternalLeading = mymetrics.tmExternalLeading
   
   '-----------------------------------------
   'Calc the Font Height from Its Parts
   '----------------------------------------
   iHeight = Ascent + Descent - InternalLeading                        

  '---------------------------------------------
  'Verify the Height (in Pixels) is Correct
  '---------------------------------------------
  VerifyHeightPixels = ScaleY(Me.Text1.FontSize, vbPoints, vbPixels)
     
   '-----------------------------------
   'Verify the Font Size is Correct
   '-----------------------------------
   VerifyFSizePoints = ScaleY(iHeight, vbPixels, vbPoints)
 
 

   '********
   'WRAPUP
   '********
   Call ReleaseDC(hWnd, hDC)

End Sub

Private Sub fCreateFontIndirect(hDC As Long, strFontName As String, lngFontSize As Long)
   'Modified From:   'URL: http://www.allapi.net/
 
    Dim ThisFont As LOGFONT
    Dim rFont As Variant
     

    'Set the height of the font
    ThisFont.lfHeight = (lngFontSize * -20) / Screen.TwipsPerPixelY        '<< WHAT"S THE -20
    
    'Create the font
    rFont = CreateFontIndirect(ThisFont)
    If IsNull(rFont) Then
       MsgBox "fCreateFontIndirect Failed"
   End If
    
    'Select the font into the Controls device context
    Call SelectObject(hDC, rFont)

End Sub