PP 2007 VBA to get available font list

[msadiqrajani]

Hello,

Is there any way to get available font list on vba form list box.

I am developing a simple macro to format multiple textbox at once.For font name I need list of available fonts on user pc.

Any help will be appreciated.

Thanks

[Cosmo]

Option Explicit

Public Const LF_FACESIZE = 32

Private fontNameCollection As New Collection
    ' 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

Function OutputFontName(fontName As String)
    ' Add to a private collection and return that collection in called function?
    fontNameCollection.Add fontName, fontName
End Function

'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
    On Error GoTo errorcode
    Dim FaceName As String
    FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
    OutputFontName Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
    EnumFontFamProc = 1
    Exit Function
    errorcode:
    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 Function ListAllFonts(Optional hWndTarget As Variant) As Collection
    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
    ' Debug.Print fontNameCollection.Count & " Fonts found."
    Set ListAllFonts = fontNameCollection
    Exit Function
    Error_H:
    ' MsgBox "Error in sub 'ListAllFonts'"
    Resume Finish
End Function
 
Sub test()
    Dim fontList As Collection
    Set fontList = New Collection
    On Error Resume Next
    Set fontList = ListAllFonts()
    If fontList.Count > 0 Then
        Dim fontName 
        For Each fontName In fontList
            Debug.Print fontName
        Next fontName
    End If
    On Error GoTo 0
End Sub

[John Wilson]

If you have Word you might also try...

Sub fontsthere()
    Dim i As Integer
    Dim wrdapp As Object
    Dim strfont As String
    On Error Resume Next
    Set wrdapp = GetObject(, "Word.Application")
    If Err <> 0 Then Set wrdapp = CreateObject("Word.Application")
    For i = 1 To wrdapp.fontnames.Count
        strfont = strfont & wrdapp.fontnames(i) & vbCrLf
    Next
    MsgBox strfont
    wrdapp.Quit
End Sub