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

Question

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

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

Answer 1

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

• < w: embedRegular>
• < вес: embedBold>
• < вес: embedItalic>
• < вес: embedBoldItalic>

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

Более подробная информация здесь: 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