List all fonts

Found this on the internet and testet it, works great.
Thanks Timbo, London, England
Option Explicit

Public Const LF_FACESIZE = 32

'types expected by the Windows callback
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

Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type

Private Declare Function EnumFontFamilies Lib "gdi32" Alias "EnumFontFamiliesA" _
(ByVal hDC As Long, ByVal lpszFamily As String, ByVal lpEnumFontFamProc As Long, LParam As Any) As Long

Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long

'This sub can be modified to output each font name as required. It is called once for each installed font
Sub OutputFontName(FontName As String)
Debug.Print FontName
End Sub

'This function is built to specifications expected by Windows,
' therefore do not alter it unless you know what you're doing
'http://allapi.mentalis.org/apilist/EnumFontFamilies.shtml
Private Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, _
ByVal FontType As Long, LParam As Long) As Long
Dim FaceName As String

FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
OutputFontName Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
EnumFontFamProc = 1
End Function

'This sub kicks off the font enumeration process.
'You may pass the hWnd of a form or other object to it, but it is not required
Public Sub ListAllFonts(Optional hWndTarget As Variant)
Dim hDC As Long

On Error GoTo Error_H

If IsMissing(hWndTarget) Then hWndTarget = GetFocus

hDC = GetDC(hWndTarget)
'this line requests Windows to call the 'EnumFontFamProc' function for each installed font
EnumFontFamilies hDC, vbNullString, AddressOf EnumFontFamProc, ByVal 0&

Finish:
On Error Resume Next
ReleaseDC hWndTarget, hDC
Exit Sub
Error_H:
MsgBox "Error in sub 'ListAllFonts'"
Resume Finish
End Sub