Create an API hFont from a VB StdFont object

If you are working with API based controls you will find that to set fonts you need a GDI hFont handle to the font. The StdFont object does not directly supply you with this handle. Although it is possible to cast the StdFont object as an IFont object, which does have a hFont handle property, you still don't get full control over the setting of the font properties, and note that since you cannot call the AddRefhFont method from VB there may be instances in which the handle unexpectedly becomes invalid.

The alternative to this is to create a GDI font from first principles using the API call CreateFontIndirect. This takes a LOGFONT structure which specifies the font to be created. The LOGFONT structure's members are quite closely related to the StdFont object's properties - but you need to be careful when specifying the font name and size. This tip contains a reliable function to transform a StdFont object into a LOGFONT and briefly demonstrates using a GDI font created by this method.

The demonstration is a bit pointless - it only does what could be done more simply using the StdFont object and the Print method. However, this code is really useful if you are building a control using the API or you need to draw on a GDI device context.

Start a new project in VB, and add a standard module. Then add the following code to the module:

' Font:
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 Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" ( _
   lpLogFont As LOGFONT) As Long
Private Declare Function MulDiv Lib "kernel32" ( _
   ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
   ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Const LOGPIXELSY = 90

' Testing the font:
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" ( _
   ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _
   lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_CALCRECT = &H400
Private Declare Function SelectObject Lib "gdi32" ( _
   ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function OffsetRect Lib "user32" ( _
   lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long

Public Sub Test(ByVal hdc As Long, fntThis As StdFont)
Dim hFnt As Long
Dim hFntOld As Long
Dim tR As RECT

   ' Create a LOGFONT structure equivalent to the
   ' StdFont font:
   pOLEFontToLogFont fntThis, hdc, tLF

   ' Convert the LOGFONT into a font handle:
   hFnt = CreateFontIndirect(tLF)

   ' Test the font out:
   hFntOld = SelectObject(hdc, hFnt)
   DrawText hdc, "This is a test", -1, tR, DT_CALCRECT
   OffsetRect tR, 32, 32
   DrawText hdc, "This is a test", -1, tR, 0&
   SelectObject hdc, hFntOld

   ' Always remember to delete the font when finished
   ' with it:
   DeleteObject hFnt

End Sub

Private Sub pOLEFontToLogFont(fntThis As StdFont, ByVal hdc As Long, tLF As LOGFONT)
Dim sFont As String
Dim iChar As Integer
Dim b() As Byte

   ' Convert an OLE StdFont to a LOGFONT structure:
   With tLF
     sFont = fntThis.Name
     b = StrConv(sFont, vbFromUnicode)
     For iChar = 1 To Len(sFont)
       .lfFaceName(iChar - 1) = b(iChar - 1)
     Next iChar
     ' Based on the Win32SDK documentation:
     .lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hdc, LOGPIXELSY)), 72)
     .lfItalic = fntThis.Italic
     If (fntThis.Bold) Then
       .lfWeight = FW_BOLD
       .lfWeight = FW_NORMAL
     End If
     .lfUnderline = fntThis.Underline
     .lfStrikeOut = fntThis.Strikethrough
     .lfCharSet = fntThis.Charset
   End With

End Sub

To try out the code, add a Command Button to your test project's main form. Then add this code to the Button's Click event:

Private Sub Command1_Click()

   Dim sFnt As New StdFont
   sFnt.Name = "Arial"
   sFnt.Size = 48
   Test Me.hdc, sFnt

End Sub

Run the project. It will draw the text "This is a Test" in 48-point Arial by selecting a GDI font into the form's device context.