Option Explicit 
 
Public Sub Main() 
     
    Dim sMsg            As String 
     
    sMsg = GetFonts(ActiveDocument) 
    MsgBox "The fonts in this document are:" & vbNewLine & vbNewLine & sMsg 
    If Not CompareFonts(sMsg) = vbNullString Then 
        MsgBox "The following fonts are used in this document," & _ 
        vbNewLine & "but are not installed on this PC:" & vbNewLine & CompareFonts(sMsg) 
    End If 
     
End Sub 
 
Private Function GetFonts(ByVal oDocument As Document) As String 
     
    Dim oParagraph      As Paragraph 
    Dim i               As Integer 
    Dim oWord           As Words 
    Dim sFontType       As String 
    Dim sMsg            As String 
     
    For Each oParagraph In oDocument.Paragraphs 
        For i = 1 To oParagraph.Range.Characters.Count 
            sFontType = oParagraph.Range.Characters(i).Font.Name 
            If InStr(1, sMsg, sFontType) = 0 Then 
                sMsg = sMsg & sFontType & vbNewLine 
            End If 
        Next 
    Next 
    GetFonts = sMsg 
     
End Function 
 
Private Function CompareFonts(ByVal oFonts As String) As String 
     
    Dim vFont           As Variant 
    Dim sMsg            As String 
    Dim xFont           As Variant 
    Dim i               As Long 
    Dim allFonts        As String 
     
    For Each vFont In FontNames 
        allFonts = allFonts & vbNewLine & vFont 
    Next vFont 
    xFont = Split(oFonts, vbNewLine) 
    For i = 0 To UBound(xFont) 
        If InStr(allFonts, xFont(i)) = 0 Then 
            sMsg = sMsg & vbNewLine & xFont(i) 
        End If 
    Next i 
    CompareFonts = sMsg 
     
End Function