Font names

[Jimbob]

Is there an easy way of getting the names of all the fonts inststalled on a achine, so that I can put hem in a list box for user selection

I don't want to use the common dialog, because I ONLY want them to see the font name...

[HeSaidJoe]

[code]
'list the font files in a list box
'controls = list1,form1,commnad1
'add this to the General Declarations of the application
'
Option Explicit
'
Private Declare Function SHGetSpecialFolderLocation Lib _
"Shell32" (ByVal hwndOwner As Long, _
ByVal nFolder As Integer, ppidl As Long) As Long

Private Declare Function SHGetPathFromIDList Lib _
"Shell32" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal szPath As String) As Long

Private Const CSIDL_FONTS = &H14&
Private Const MAX_PATH = 255

Public Function GetFontFolderPath(ByVal pHwnd As Long) As String
Dim lReturn As Long
Dim lPidl As Long
Dim lPath As Long
Dim sPath As String

sPath = Space$(MAX_PATH)
lReturn = SHGetSpecialFolderLocation(pHwnd, CSIDL_FONTS, lPidl)

' Get lPidl for Id...
If lReturn = 0 Then
' If success is 0
lReturn = SHGetPathFromIDList(lPidl, sPath)
' Get Path from Item Id List
If lReturn = 1 Then
sPath = Left(sPath, InStr(sPath, vbNullChar) - 1)
' Fix path string
GetFontFolderPath = sPath
' Return Font path
End If
End If
End Function
'
'use this code in any event..here I use a commnad button
'
Private Sub Command1_Click()

Dim strFontDir As String
Dim strFont As String

strFontDir = GetFontFolderPath(Me.hWnd)
strFont = Dir(strFontDir & "\*.*")

Do Until strFont = ""
List1.AddItem strFont
strFont = Dir
Loop
End Sub
[code]

[Jimbob]

excellent, but is it possible to get the actual name of the font, eg Arial etc

[kedaman]

Or without API's

For n = 0 To Screen.FontCount - 1
    list1.AddItem (Screen.Fonts(n))
Next n