PowerPoint VBA get missing fonts

Question

I am trying to get some kind of Preflight Report from InDesign implemented in PowerPoint. Do you know how to get list of missing/installed fonts? Or how to check if this:

ActivePresentation.Fonts(i)

is installed font?

Function getFontList()

 Dim LF As LOGFONT
 Dim hDC As Long

 hDC = GetDC(0)
 EnumFontFamiliesEx hDC, LF, AddressOf EnumFontFamProc, ByVal 0&, 0
 QuickSortStringArray FontArray(), 0, UBound(FontArray)

End Function
Sub Main()

Dim PCtr As Long, FCtr As Long
Dim Found As Boolean, FontsMissing As Boolean
Dim Msg As String
Msg = "The Following Presentation fonts were not found:"
Call getFontList
For PCtr = 0 To ActivePresentation.Fonts.Count - 1
    Found = False
    For FCtr = LBound(FontArray) To UBound(FontArray)
        Found = (ActivePresentation.Fonts(PCtr).Name = FontArray(FCtr))
        If Found Then Exit For
    Next
    If Not Found Then
        FontsMissing = True
        Msg = Msg & vbCrLf & ActivePresentation.Fonts(PCtr).Name
    End If
Next
If FontsMissing Then
    MsgBox Msg
End If

End Sub

Answer 1

There is a solution using Windows API calls here.

This VBA fills an Access combo box, however you may be able to adapt it to your needs, as all you need to do is get an array or other structure containing the fonts installed in Windows and compare it against your ActivePresentation.Fonts(i)

EDIT:

Given the code from the link above (the relevant parts are reproduced here):

Option Explicit

Public Const NTM_REGULAR = &H40&
Public Const NTM_BOLD = &H20&
Public Const NTM_ITALIC = &H1&
Public Const TMPF_FIXED_PITCH = &H1
Public Const TMPF_VECTOR = &H2
Public Const TMPF_DEVICE = &H8
Public Const TMPF_TRUETYPE = &H4
Public Const ELF_VERSION = 0
Public Const ELF_CULTURE_LATIN = 0
Public Const RASTER_FONTTYPE = &H1
Public Const DEVICE_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64
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 EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hDC As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, ByVal LParam As Long, ByVal dw As Long) 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    

'Declare variables required for this module.
Dim FontArray() As String   'The Array that will hold all the Fonts (needed for sorting)
Dim FntInc As Integer       'The FontArray element incremental counter.


Private Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, ByVal FontType As Long, LParam As Long) As Long
   Dim FaceName As String

  'convert the returned string to Unicode
   FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)

   'Dimension the FontArray array variable to hold the next Font Name.
   ReDim Preserve FontArray(FntInc)
   'Place the Font name into the newly dimensioned Array element.
   FontArray(FntInc) = Left$(FaceName, InStr(FaceName, vbNullChar) - 1)

  'continue enumeration
   EnumFontFamProc = 1

   'Increment the Array Element Counter.
   FntInc = UBound(FontArray) + 1
End Function

Public Sub QuickSortStringArray(avarIn() As String, ByVal intLowBound As Integer, _
                                ByVal intHighBound As Integer)
  'GENERAL SUB-PROCEDURE
  '=====================

  'Quicksorts the passed array of Strings
  'avarIn() - array of Strings that gets sorted
  'intLowBound - low bound of array
  'intHighBound - high bound of array

  'Declare Variables...
  Dim intX As Integer, intY As Integer
  Dim varMidBound As Variant, varTmp As Variant

  'Trap Errors
  On Error GoTo PROC_ERR

  'If there is data to sort
  If intHighBound > intLowBound Then
    'Calculate the value of the middle array element
    varMidBound = avarIn((intLowBound + intHighBound) \ 2)
    intX = intLowBound
    intY = intHighBound

    'Split the array into halves
    Do While intX <= intY
      If avarIn(intX) >= varMidBound And avarIn(intY) <= varMidBound Then
        varTmp = avarIn(intX)
        avarIn(intX) = avarIn(intY)
        avarIn(intY) = varTmp
        intX = intX + 1
        intY = intY - 1
      Else
        If avarIn(intX) < varMidBound Then
          intX = intX + 1
        End If
        If avarIn(intY) > varMidBound Then
          intY = intY - 1
        End If
      End If
    Loop

    'Sort the lower half of the array
    QuickSortStringArray avarIn(), intLowBound, intY

    'Sort the upper half of the array
    QuickSortStringArray avarIn(), intX, intHighBound
  End If

PROC_EXIT:
  'Outta here
  Exit Sub

PROC_ERR:
  'Display the Error Trapped
  MsgBox "Error: " & Err.Number & ". " & Err.description, , _
    "QuickSortStringArray"
  'Jump to...
  Resume PROC_EXIT
End Sub

the following code will populate - and sort - the FontArray() variable:

Dim LF As LOGFONT
Dim hDC As Long
hDC = GetDC(0)
EnumFontFamiliesEx hDC, LF, AddressOf EnumFontFamProc, ByVal 0&, 0
QuickSortStringArray FontArray(), 0, UBound(FontArray)

If you don't need a sorted array, just delete the last line of the code above.

To get a messagebox containing a list of ActivePresentation.Fonts that are not installed:

Dim PCtr as Long, FCtr as Long
Dim Found as Boolean, FontsMissing as Boolean
Dim Msg as String
Msg = "The Following Presentation fonts were not found:"
For PCtr = 0 to ActivePresentation.Fonts.Count - 1
    Found = False
    For FCtr = LBound(FontArray) to UBound(FontArray)
        Found = (ActivePresentation.Fonts(PCtr).Name = FontArray(FCtr))
        If Found Then Exit For
    Next
    If Not Found Then
        FontsMissing = True
        Msg = Msg  & vbCrLf & ActivePresentation.Fonts(PCtr).Name 
    End If
Next
If FontsMissing Then
    MsgBox Msg
End If

I haven't tested this last code, so if it doesn't work, post a comment with the error and I'll edit it.

EDIT 2:

Combining the two code sections:

Dim PCtr as Long, FCtr as Long
Dim Found as Boolean, FontsMissing as Boolean
Dim Msg as String
Dim LF As LOGFONT
Dim hDC As Long
hDC = GetDC(0)
EnumFontFamiliesEx hDC, LF, AddressOf EnumFontFamProc, ByVal 0&, 0
QuickSortStringArray FontArray(), 0, UBound(FontArray)
Msg = "The Following Presentation fonts were not found:"
For PCtr = 0 to ActivePresentation.Fonts.Count - 1
    Found = False
    For FCtr = LBound(FontArray) to UBound(FontArray)
        Found = (ActivePresentation.Fonts(PCtr).Name = FontArray(FCtr))
        If Found Then Exit For
    Next
    If Not Found Then
        FontsMissing = True
        Msg = Msg  & vbCrLf & ActivePresentation.Fonts(PCtr).Name 
    End If
Next
If FontsMissing Then
    MsgBox Msg
End If