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]

[vba]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
[/vba]

[John Wilson]

If you have Word you might also try...

[VBA]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[/VBA]