Список шрифтов, используемых в документе Word (более быстрый метод)

Question

Я работаю над процессом проверки документов, чтобы убедиться, что они соответствуют корпоративным стандартам.Один из шагов - убедиться, что в документе Word не используются неподтвержденные шрифты.

У меня есть следующий фрагмент кода, который работает:

    Dim wordApplication As Word.ApplicationClass = New Word.ApplicationClass()
    Dim wordDocument As Word.Document = Nothing

    Dim fontList As New List(Of String)()

    Try
        wordDocument = wordApplication.Documents.Open(FileName:="document Path")
        'I've also tried using a for loop with an integer counter, no change in speed'
        For Each c As Word.Range In wordDocument.Characters
            If Not fontList.Contains(c.Font.Name) Then
                fontList.Add(c.Font.Name)
            End If
        Next

Но это невероятно медленно!Невероятно медленный = 2500 символов в минуту (я рассчитал это с помощью StopWatch).Большинство моих файлов - около 6000 слов / 30000 символов (около 25 страниц).Но есть некоторые документы, которые находятся на сотнях страниц ...

Есть ли более быстрый способ сделать это?Я должен поддерживать файлы формата Office 2003, поэтому Open XML SDK не подходит.

- ОБНОВЛЕНИЕ -

Я попытался запустить это как Wordмакрос (используя найденный код @ http://word.tips.net/Pages/T001522_Creating_a_Document_Font_List.html) и он работает намного быстрее (менее минуты). К сожалению, для моих целей я не верю, что макрос будет работать.

- ОБНОВЛЕНИЕ# 2 -

Я воспользовался советом Криса и на лету преобразовал документ в формат Open XML, а затем использовал следующий код, чтобы найти все объекты RunFonts и прочитать имя шрифта:

    Using docP As WordprocessingDocument = WordprocessingDocument.Open(tmpPath, False)
        Dim runFonts = docP.MainDocumentPart.Document.Descendants(Of RunFonts)().Select(
                            Function(c) If(c.Ascii.HasValue, c.Ascii.InnerText, String.Empty)).Distinct().ToList()

        fontList.AddRange(runFonts)
    End Using

Answer 1

Возможно, вам придется поддерживать Office 2003, но это не значит, что вы должны анализировать его в этом формате.Возьмите документы Office 2003, временно преобразуйте их в файлы DOCX, откройте их как ZIP-файл, проанализируйте файл /word/fontTable.xml и затем удалите DOCX.

Answer 2

другой способ, который я нашел без кодирования: * экспортировать документ в формате PDF * открыть его в Adobe Reader * в Adobe Reader перейдите в меню «Файл» \ «Свойства», а затем на вкладку «Шрифты», в которой перечислены семейные шрифты и суб-шрифты, используемые в документе.

Answer 3

Вы можете значительно ускорить процесс, перебирая абзацы.Только если абзац содержит смешанные шрифты, вам нужно проверять символ за символом.Свойства Name, Bold, Italic и т. Д. Имеют специальное неопределенное значение, представляющее собой пустую строку для Name или 9999999 для атрибутов стиля.

Так, например, если Bold = 9999999, это означаетабзац содержит несколько жирным шрифтом и несколько жирным шрифтом.

Я включаю следующий фрагмент, чтобы показать общую идею:

For Each P as Paragraph in doc.Paragraphs
    Dim R as Range = P.Range
    If R.Font.Name = "" Or R.Font.Bold = 9999999 Or R.Font.Italic = 9999999
        Or R.Font.Underline = 9999999 Or R.Font.Strikethrough = 9999999 Then
        ' This paragraph uses mixed fonts, so we need to analyse character by character
        AnalyseCharacterByCharacter(R)
    Else
        ' R.Font is used throughout this paragraph
        FontHasBeenUsed(R.Font)
    End If
 Next

Answer 4

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

Намного, намного, намного быстрее - это перебирать шрифты.Единственная хитрость в том, что Слово иногда суетливо относится к пробелам и так далее.Это хорошо работает для меня

Sub FindAllFonts()
    Dim lWhichFont As Long, sTempName As String, sBuffer As String
    For lWhichFont = 1 To FontNames.Count
       sTempName = FontNames(lWhichFont)
       If FindThisFont(sTempName) Then
          sBuffer = sBuffer & "Found " & sTempName & vbCrLf
        Else
           If FindThisFont(Replace(sTempName, " ", "")) Then
              sBuffer = sBuffer & "Found " & sTempName & " *" & vbCrLf
           End If
        End If
   Next
   Documents.Add
   Selection.TypeText Text:=sBuffer
End Sub

Function FindThisFont(sName As String) As Boolean
   Selection.HomeKey Unit:=wdStory
   Selection.Find.ClearFormatting
   With Selection.Find
       .Font.Name = sName
       .Forward = True
       .Format = True
       .Execute
       If .Found() Then
          FindThisFont = True
       Else
          FindThisFont = False
       End If
   End With
End Function

Работает очень быстро (единственным медленным компонентом является итерация шрифта)

(Очевидно, он не найдет шрифты не в вашей системе, но еслиВы пытаетесь подготовить к отправке то, что написали, и какая-то программа-помощник добавила Helvetica или MS Minchin, вы можете найти это)

Хорошо, люди сказали мне, что это не то, что хотят все, люди хотятнайти шрифты, которых нет на их машинах.Но другой путь все еще слишком медленный и включает в себя поиск множества вещей, которых там нет.Итак, вот альтернатива, которая сохраняется как rtf и обрабатывает заголовок rtf.

Sub FIndAllFonts2()
    Dim sOldName As String, sOldPath As String, sBuffer As String, sBuffer2 As String, sOut As String, sBit
    Dim lCounter As Long, lPos As Long, lPos2 As Long, lStopAt As Long
    Dim objPic As InlineShape, objShp As Shape
    ' rememer old name for reloading
    sOldName = ActiveDocument.Path
    'delete image to make file out small
    For Each objPic In ActiveDocument.InlineShapes: objPic.Delete: Next
    For Each objShp In ActiveDocument.Shapes: objShp.Delete: Next
    ActiveDocument.SaveAs "tempout.rtf", wdFormatRTF
    sTempFile = ActiveDocument.Path
    ActiveDocument.Close
    lPos2 = 1
    ' we only want the header, but we don't know how long the file is
    'I am using a Mac, so filesystemobject not available
    ' if you end up having a huge header, make 2500 bigger
    lStopAt = 2500
    Open sTempFile For Input As #1
    Do While Not EOF(1) And lPos2 < lStopAt
        sBit = Input(1, #1)
        sBuffer = sBuffer & sBit
        lPos2 = lPos2 + 1
    Loop
    Close #1
    'delete temp file
    Kill sTempFile
    ' loop through header, fonts identified in the table as {\f1\
    ' if you have more than 100 fonts, make this bigger
    ' not all numbers are used
    lStopAt = 100
    For lCounter = 1 To lStopAt
        lPos = InStr(sBuffer, "{\f" & lCounter & "\")
        If lPos > 0 Then
            sBuffer = Mid(sBuffer, lPos)
            lPos = InStr(sBuffer, ";")
            sBuffer2 = Left(sBuffer, lPos - 1)
            'this is where you would look for the alternate name if you want it
            lPos = InStr(sBuffer2, "{\*\falt")
            If lPos > 0 Then
                sBuffer2 = Left(sBuffer2, lPos - 1)
                sBuffer2 = Mid(sBuffer2, InStrRev(sBuffer2, " ") + 1) & " *" 'indicate it is the shorter ascii name
            Else
                sBuffer2 = Mid(sBuffer2, InStrRev(sBuffer2, "}") + 1)
            End If
            sOut = sOut & sBuffer2 & vbCrLf
        End If
    Next
    'reopen old file
    Documents.Open sOldName
    Set newdoc = Documents.Add
    sOut = "Fonts in use in document " & sOldName & vbCrLf & sOut
    Selection.TypeText Text:=sOut
End Sub

Этот проект проходит через мой 350-страничный черновой вариант менее чем за 20 секунд на MacBook Pro.Так что это достаточно быстро, чтобы быть полезным.

Answer 5

Если вы хотите, чтобы все шрифты использовались в вашем документе.Вы можете просто получить их все через одну строку, используя OPEN XML:

 using (WordprocessingDocument doc = WordprocessingDocument.Open(filePath, true))
 {
     var fontlst = doc.MainDocumentPart.FontTablePart.Fonts.Elements<Font>();
 }

Каждый элемент Font имеет свое свойство «Имя», на которое ссылается элемент в свойствах текстового прогона.

Подсказка: вы должны учитывать, что каждое слово док. не имеет более 2 частей таблицы шрифтов, одну в основной части, а другую в глоссарии, поэтому не забудьте рассмотреть также глоссарий, если это необходимо.

Вы можете скачать OPEN XMLSDK от здесь

Answer 6

Это может быть быстрее, чем преобразование документов в .docx перед обработкой их с помощью OpenXml (для записи вы также можете работать со свойством document.Content.WordOpenXML вместо document.Content.XML):

using System;
using System.Collections.Generic;
using System.IO;
using System.Linq;
using System.Xml.Linq;
using Word = NetOffice.WordApi;

namespace _5261108
{
    class Program
    {
        static void Main(string[] args)
        {
            using (var app = new Word.Application())
            {
                var doc = app.Documents.Open(Path.GetFullPath("test.docx"));

                foreach (var font in GetFontNames(doc))
                {
                    Console.WriteLine(font);
                }

                app.Quit(false);
            }

            Console.ReadLine();
        }

        private static IEnumerable<string> GetFontNames(Word.Document document)
        {
            var xml = document.Content.XML;
            var doc = XDocument.Parse(xml);
            var fonts = doc.Descendants().First(n => n.Name.LocalName == "fonts").Elements().Where(n => n.Name.LocalName == "font");
            var fontNames = fonts.Select(f => f.Attributes().First(a => a.Name.LocalName == "name").Value);
            return fontNames.Distinct();
        }
    }
}

Конвертировано для вашего удобства:

Imports System.Collections.Generic
Imports System.IO
Imports System.Linq
Imports System.Xml.Linq
Imports Word = NetOffice.WordApi

Namespace _5261108
    Class Program
        Private Shared Sub Main(args As String())
            Using app = New Word.Application()
                Dim doc = app.Documents.Open(Path.GetFullPath("test.docx"))

                For Each font As var In GetFontNames(doc)
                    Console.WriteLine(font)
                Next

                app.Quit(False)
            End Using

            Console.ReadLine()
        End Sub

        Private Shared Function GetFontNames(document As Word.Document) As IEnumerable(Of String)
            Dim xml = document.Content.XML
            Dim doc = XDocument.Parse(xml)
            Dim fonts = doc.Descendants().First(Function(n) n.Name.LocalName = "fonts").Elements().Where(Function(n) n.Name.LocalName = "font")
            Dim fontNames = fonts.[Select](Function(f) f.Attributes().First(Function(a) a.Name.LocalName = "name").Value)
            Return fontNames.Distinct()
        End Function
    End Class
End Namespace

'=======================================================
'Service provided by Telerik (www.telerik.com)
'Conversion powered by NRefactory.
'Twitter: @telerik
'Facebook: facebook.com/telerik
'=======================================================

Answer 7

Попробуйте это:

Sub Word_Get_Document_Fonts()
  Dim report As String
  Dim J As Integer
  Dim font_name As String
  report = "Fonts in use in this document:" & vbCr & vbCr
  For J = 1 To FontNames.Count
    font_name = FontNames(J)
    Set myrange = ActiveDocument.Range
    myrange.Find.ClearFormatting
    myrange.Find.Font.Name = font_name
    With myrange.Find
      .text = "^?"
      .Replacement.text = ""
      .Forward = True
      .Wrap = wdFindStop
      .Format = True
    End With
    myrange.Find.Execute
    If myrange.Find.Found Then
      report = report & font_name & vbCr
    End If
  Next J
  MsgBox (report)
End Sub