Determine whether a Word document contains a restricted font using VBA

Is there a way to determine whether or not a Word document (specifically 2007, if that matters) contains a restricted font using VBA?

I don't necessarily need a way to remove the font, just to determine whether or not the document contains an restricted font. Also, if there's only a way to check for an embedded font, that's acceptable, because in my case, it will almost always be a restricted font.

As you're using Word 2007 you can try to inspect the OOXML of the document to check whether a particular font is embedded or not. As far as I can determine, if it is embedded then in the XML, the font will have one or more of the following child nodes:

• < w:embedRegular>
• < w:embedBold>
• < w:embedItalic>
• < w:embedBoldItalic>

(had to put in spaces otherwise it would not display correctly)

More information here: http://msdn.microsoft.com/en-us/library/documentformat.openxml.wordprocessing.font.aspx

Based on this, you can then put something together to extract this information - I threw together an example below that looks at the active document.

I have to admit this is not that pretty and it could certainly do with some optimisation, but it does the job. Don't forget to add a reference to MSXML to your VBA project.

' returns a delimited list of fonts that are embedded
Function GetEmbeddedFontList(Optional ByVal sDelimiter As String = ";") As String

   Dim objDOMDocument As MSXML2.DOMDocument30
   Dim objXMLNodeList As MSXML2.IXMLDOMNodeList
   Dim objXMLNodeListEmbed As MSXML2.IXMLDOMNodeList
   Dim lNodeNum As Long
   Dim lNodeNum2 As Long
   Dim sFontName As String
   Dim sReturnValue As String

   On Error GoTo ErrorHandler

   sReturnValue = ""

   Set objDOMDocument = New MSXML2.DOMDocument30
   objDOMDocument.LoadXML ActiveDocument.WordOpenXML

   ' grab the list of fonts used in the document
   Set objXMLNodeList = objDOMDocument.SelectNodes("//w:fonts/w:font")

   For lNodeNum = 0 To objXMLNodeList.Length - 1

      ' obtain the font's name
      sFontName = objXMLNodeList.Item(lNodeNum).Attributes(0).Text

      'check its child nodes to see if any contain the word "embed", if so, then the font is embedded
      For lNodeNum2 = 0 To objXMLNodeList.Item(lNodeNum).ChildNodes.Length - 1

         If objXMLNodeList.Item(lNodeNum).ChildNodes(lNodeNum2).nodeName Like "*embed*" Then

            sReturnValue = sReturnValue & sFontName & sDelimiter  ' add it to the list

            Exit For

         End If

      Next lNodeNum2

   Next lNodeNum

ErrorExit:

   GetEmbeddedFontList = sReturnValue

   Exit Function

ErrorHandler:

   sReturnValue = ""

   Resume ErrorExit:

End Function