ChooseFont API

[FrogBoy666]

Would someone mind posting a working version of the ChooseFont API? It's the only one of the Common Dialog API's that I can't seem to make work... It's kinda frustrating to realize that I'm only a typo away from getting rid of another OCX. :)


Thanks!

[V(ery) Basic]

Look through

http://msdn.microsoft.com/library/psdk/winui/commdlg3_36k4.htm

and you'll probably see what you're not doing or doing wrong.

I think.

[FrogBoy666]

When I try to open the form, I get the message:

"There are no fonts installed.
Open the Fonts folder from the Control Panel to install fonts."

I do have fonts installed... This is the code I have:

Private Sub Command3_Click()

Dim cf As CHOOSEFONT_TYPE
Dim lfont As LOGFONT
Dim hMem As Long, pMem As Long
Dim fontname As String
Dim retval As Long

lfont.lfHeight = 0
lfont.lfWidth = 0
lfont.lfEscapement = 0
lfont.lfOrientation = 0
lfont.lfWeight = FW_NORMAL
lfont.lfItalic = 0
lfont.lfUnderline = 0
lfont.lfStrikeOut = 0
lfont.lfCharSet = DEFAULT_CHARSET
lfont.lfOutPrecision = OUT_DEFAULT_PRECIS
lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS
lfont.lfQuality = DEFAULT_QUALITY
lfont.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN
lfont.lfFaceName = "Times New Roman" & vbNullChar

' Create the memory block which will act as the LOGFONT structure buffer.
hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
pMem = GlobalLock(hMem)
CopyMemory ByVal pMem, lfont, Len(lfont)

' Initialize dialog box: Screen and printer fonts, point size between 10 and 72.
cf.lStructSize = Len(cf)
cf.hwndOwner = Form1.hWnd
cf.hDC = Printer.hDC
cf.lpLogFont = pMem
cf.iPointSize = 120
cf.Flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
cf.rgbColors = RGB(0, 0, 0)
cf.lCustData = 0
cf.lpfnHook = 0
cf.lpTemplateName = ""
cf.hInstance = 0
cf.lpszStyle = ""
cf.nFontType = REGULAR_FONTTYPE
cf.nSizeMin = 10
cf.nSizeMax = 72


retval = ChooseFont(cf)
If retval <> 0 Then
CopyMemory lfont, ByVal pMem, Len(lfont)

fontname = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)

Debug.Print "FONT NAME: "; fontname
Debug.Print "FONT SIZE (points):"; cf.iPointSize / 10
Debug.Print "FONT STYLE(S): ";
If lfont.lfWeight >= FW_BOLD Then Debug.Print "Bold ";
If lfont.lfItalic <> 0 Then Debug.Print "Italic ";
If lfont.lfUnderline <> 0 Then Debug.Print "Underline ";
If lfont.lfStrikeOut <> 0 Then Debug.Print "Strikeout";
Debug.Print
End If

retval = GlobalUnlock(hMem)
retval = GlobalFree(hMem)

End Sub