ChooseFont API

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!

Look through

http://msdn.microsoft.com/library/ps...mdlg3_36k4.htm

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

I think.

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:

Code:

---

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

---