Определите, содержит ли документ Word ограниченный шрифт, используя VBA

Question

Есть ли способ определить, содержит ли документ Word (в частности, 2007, если это имеет значение) шрифт с ограничениями, используя VBA?

Мне не обязательно нужен способ удалить шрифт, просто чтобы определить, содержит ли документ ограниченный шрифт.Кроме того, если есть только способ проверить наличие встроенного шрифта, это приемлемо, потому что в моем случае это почти всегда будет ограниченный шрифт.

Answer 1

Поскольку вы используете Word 2007, вы можете попытаться проверить OOXML документа, чтобы проверить, встроен ли определенный шрифт или нет.Насколько я могу определить, если он встроен в XML, шрифт будет иметь один или несколько из следующих дочерних узлов:

(пришлось вставлять пробелы, иначе он не будет отображаться правильно)

Больше информации здесь: http://msdn.microsoft.com/en-us/library/documentformat.openxml.wordprocessing.font.aspx

Исходя из этого, вы можете затем собрать что-то вместе для извлечения этой информации - ниже я собрал пример, который рассматривает активный документ.

Я должен признать, что это не так красиво, и это, безусловно, может быть сделано с некоторой оптимизацией, но это делает работу.Не забудьте добавить ссылку на MSXML в ваш проект VBA.

' 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