The new vbAccelerator Site - more VB and .NET Code and Controls

Create an API hFont from a VB StdFont object.

Author:

Steve McMahon(steve@vbaccelerator.com)

Keywords:

API,GDI,Graphics

Updated:

17/08/99

Other Tips
All Tips
By Date
By Subject


API (33)
Bit
Manipulation (3)

Clipboard (3)
Combo
Box (5)

Desktop (3)
GDI (13)
Graphics (13)
Internet (2)
Interprocess
Comms (3)

Keyboard (2)
Mouse (1)
Shell (1)
Sprites (1)
Subclassing (3)
Text
Box (2)

Windows (11)
Windows
Controls (10)



Submit


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 hFont handle property, unfortunately you cannot be certain this handle is valid because you cannot call the AddRefhFont method in VB.

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 tLF As LOGFONT
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
Else
.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.


&nbsp

Related Tips and Articles:

&nbsp

AboutContributeSend FeedbackPrivacy

Copyright 1998-1999, Steve McMahon ( steve@vbaccelerator.com). All Rights Reserved.
Last updated: 17/08/99