The Logical Font

[Yonatan]

If I want to create an hFont from a LOGFONT structure, I can use the CreateFontIndirect API.

How can I do the opposite? (Fill a LOGFONT structure according to an hFont)

------------------
Yonatan
Teenage Programmer
E-Mail: [email protected]
ICQ: 19552879

[Aaron Young]

One thing you could do would be to Select the Font into a Device Context, then use the GetTextMetrics and GetTextFace APIs to get the Fonts Details, if you absolutely MUST fill a LOGFONT Structure you can Enumerate the Members of the FontFace Returned by GetTextFace for the Device Context until the Font Size Matches the Size Returned by the GetTextMetrics API.

------------------
Aaron Young
Analyst Programmer
[email protected]
[email protected]

[Yonatan]

Thanks Aaron! It works!

For anyone who doesn't understand what we're talking about, but wants to do the same thing, here is working code:

Option Explicit


Private Const LF_FACESIZE = 32


Private Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName(LF_FACESIZE) As Byte
End Type


Private Type TEXTMETRIC
        tmHeight As Long
        tmAscent As Long
        tmDescent As Long
        tmInternalLeading As Long
        tmExternalLeading As Long
        tmAveCharWidth As Long
        tmMaxCharWidth As Long
        tmWeight As Long
        tmOverhang As Long
        tmDigitizedAspectX As Long
        tmDigitizedAspectY As Long
        tmFirstChar As Byte
        tmLastChar As Byte
        tmDefaultChar As Byte
        tmBreakChar As Byte
        tmItalic As Byte
        tmUnderlined As Byte
        tmStruckOut As Byte
        tmPitchAndFamily As Byte
        tmCharSet As Byte
End Type


Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hDC As Long, lpMetrics As TEXTMETRIC) As Long
Private Declare Function GetTextFace Lib "gdi32" Alias "GetTextFaceA" (ByVal hDC As Long, ByVal nCount As Long, ByVal lpFacename As String) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long


Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal cbLength As Long)


Private m_hFont As Long
Private m_hMemDC As Long


Sub StripNulls(sRetValue As String)
    Dim iPos As Integer
    iPos = InStr(sRetValue, vbNullChar)
    If iPos > 0 Then sRetValue = Left(sRetValue, iPos - 1)
End Sub


Private Sub hFontCreate(lpLogFont As LOGFONT)
    m_hFont = CreateFontIndirect(lpLogFont)
    m_hMemDC = CreateCompatibleDC(0)
    Call SelectObject(m_hMemDC, m_hFont)
End Sub


Sub hFontDelete()
    Call DeleteObject(m_hFont)
    Call DeleteDC(m_hMemDC)
End Sub


Private Function hFontToLogFont() As LOGFONT
    Dim sFaceNameBuf As String, tMetric As TEXTMETRIC
    sFaceNameBuf = String(LF_FACESIZE, vbNullChar)
    Call GetTextFace(m_hMemDC, LF_FACESIZE, sFaceNameBuf)
    Call StripNulls(sFaceNameBuf)
    Call GetTextMetrics(m_hMemDC, tMetric)
    With hFontToLogFont
        ' Easiest way to copy string to array of bytes:
        Call CopyMemory(.lfFaceName(0), ByVal sFaceNameBuf, Len(sFaceNameBuf))
        ' Set the other properties:
        .lfHeight = tMetric.tmHeight
        .lfWidth = tMetric.tmAveCharWidth
        .lfWeight = tMetric.tmWeight
        .lfItalic = tMetric.tmItalic
        .lfUnderline = tMetric.tmUnderlined
        .lfStrikeOut = tMetric.tmStruckOut
        .lfCharSet = tMetric.tmCharSet
        .lfPitchAndFamily = tMetric.tmPitchAndFamily
    End With
End Function


Private Sub Command1_Click()
    Dim lpLogFont As LOGFONT, hFont As Long
    With lpLogFont
        ' Set some properties...
        .lfUnderline = True
        .lfStrikeOut = False
        .lfWidth = 1234
    End With
    Call hFontCreate(lpLogFont)
    lpLogFont = hFontToLogFont
    With lpLogFont
        ' Check the properties...
        Debug.Print "This should be True: " & CBool(.lfUnderline)
        Debug.Print "This should be False: " & CBool(.lfStrikeOut)
        Debug.Print "This should be 1234: " & .lfWidth
    End With
    Call hFontDelete
End Sub

------------------
Yonatan
Teenage Programmer
E-Mail: [email protected]
ICQ: 19552879