Private Sub Command1_Click()
Dim CF As ChooseFont, hMem As Long, LF As LOGFONT, aFontName As String
hMem = GlobalAlloc(GPTR, Len(LF))
CF.hInstance = App.hInstance
CF.hwndOwner = hWnd
CF.lpLogFont = hMem
CF.lStructSize = Len(CF)
CF.flags = CF_BOTH
If ChooseFont(CF) Then
CopyMemory LF, ByVal hMem, Len(LF)
aFontName = Space$(LF_FACESIZE)
CopyMemory ByVal aFontName, LF.lfFaceName(0), LF_FACESIZE
With Picture1.Font
.Name = CString(aFontName)
.Bold = LF.lfWeight
.Italic = LF.lfItalic
.Size = CF.iPointSize / 10
.Underline = LF.lfUnderline
.Charset = LF.lfCharSet
.Strikethrough = LF.lfStrikeOut
End With
Picture1.Cls
Picture1_Paint
End If
GlobalFree hMem
End Sub

Private Sub Form_Load()

End Sub

Private Sub Picture1_Paint()
Picture1.Print Picture1.Font.Name
End Sub