Как правильно копировать текст из одного документа в другой?

Question

Я хочу скопировать содержимое документа Word в другой, заменив исходные стили новыми (на основе анализа текста).

Я борюсь с методом добавления нового абзаца с определенным текстом и стилем.

Вот моя функция:

'srcPar is the paragraph in the source document
'srcDoc is the document I want to copy
'newDoc is the targetDocument (new document)
'styleName is the name of the style I want to apply
Private Function ImportWithStyle(srcPar As Paragraph, srcDoc As Document, newDoc As Document, styleName As String) As Paragraph
    Dim newPar As Paragraph
    Set newPar = newDoc.Paragraphs.Add()
    newPar.Range.Text = srcPar.Range.Text
    newPar.Range.Style = styleName
    Set ImportWithStyle = newPar
End Function

Этот метод фактически добавляет текст в мой документ, но стили не применяются правильно. Похоже, стили применяются к предыдущему абзацу, а не к вновь созданному.

Особенно, строка newPar.Range.Text = srcPar.Range.Text имеет странное поведение. Если srcPar.Range.Text равно My text, после вызова newPar.Range.Text остается пустым.

Я не уверен, что правильно использую объекты диапазонов и абзацев. Заранее спасибо за помощь.

К вашему сведению, вот как я создаю новый документ:

Private Sub CreateNewDocumentBasedOn(template As String)
    Dim newDoc As Document
    Dim srcDoc As Document
    Set srcDoc = Application.ActiveDocument
    Set newDoc = Application.Documents.Add("path to a template.dot with common styles")
    newDoc.Range.Delete
    newDoc.AttachedTemplate = template ' path to a specific business template

    Dim srcPar As Paragraph
    Dim previousPar As Paragraph ' keep a track of the last paragraph to help disambiguiting styles

    For Each srcPar In srcDoc.Paragraphs
        Dim newPar As Paragraph
        Set newPar = CopyAndTransformParagraph(srcPar, srcDoc, newDoc, previousPar)
        If newPar.Style <> "CustomStyles_Ignore" Then Set previousPar = newPar
    Next

End Sub

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

Private Function CopyAndTransformParagraph(srcPar As Paragraph, srcDoc As Document, newDoc As Document, previousPar As Paragraph) As Paragraph
    Dim parText As String
    parText = Trim(srcPar.Range.Text)
    ' check all rules for importing a document

    ' Rule : ignore § with no text
    If Match(parText, "^\s*$") Then
        Set CopyAndTransformParagraph = ImportWithStyle(srcPar, srcDoc, newDoc, "CustomStyles_Ignore")

    ' Rule : if § starts with a '-', import as list bulleted
    ElseIf Left(parText, 1) = "-" Then
        Set CopyAndTransformParagraph = ImportWithStyle(srcPar, srcDoc, newDoc, "CustomStyles_ListBulleted")


    ' Rule : if § starts with roman char, import as list roman. Also check if previous paragraph is not a list alpha
    ElseIf Match(parText, "^[ivxlcdm]+\.") Then
        If previousPar Is Nothing Then
              Set CopyAndTransformParagraph = ImportWithStyle(srcPar, srcDoc, newDoc, "CustomStyles_ListRoman")
        ElseIf previousPar.Style = "CustomStyles_ListAlpha" Then 'because romans chars can also be part of an alpha list
              Set CopyAndTransformParagraph = ImportWithStyle(srcPar, srcDoc, newDoc, "CustomStyles_ListAlpha")
        Else
              Set CopyAndTransformParagraph = ImportWithStyle(srcPar, srcDoc, newDoc, "CustomStyles_ListRoman")
        End If


    ' Rule : if § starts with a char, import as list alpha
    ElseIf Match(parText, "^[A-Za-z]+\.") Then
         Set CopyAndTransformParagraph = ImportWithStyle(srcPar, srcDoc, newDoc, "CustomStyles_ListAlpha")

    ' Rule : if § starts with a number, import as list numbered
    ElseIf Match(parText, "^\d+\.") Then
        If previousPar Is Nothing Then
            Set CopyAndTransformParagraph = ImportWithStyle(srcPar, srcDoc, newDoc, "CustomStyles_NormalOutline")
        ElseIf previousPar.Style = "CustomStyles_NormalOutline" And Left(parText, 2) = "1." Then
            Set CopyAndTransformParagraph = ImportWithStyle(srcPar, srcDoc, newDoc, "CustomStyles_ListNumbered")
        Else
            Set CopyAndTransformParagraph = ImportWithStyle(srcPar, srcDoc, newDoc, "CustomStyles_NormalOutline")
        End If

    ' No rule applied
    Else
         Set CopyAndTransformParagraph = ImportWithStyle(srcPar, srcDoc, newDoc, "CustomStyles_Ignore")
    End If

End Function

[Изменить] Я попробовал другой метод:

Private Function ImportWithStyle(srcPar As Paragraph, srcDoc As Document, newDoc As Document, styleName As String) As Paragraph

    srcPar.Range.Copy

    Dim r As Range
    Set r = newDoc.Content
    r.Collapse Direction:=WdCollapseDirection.wdCollapseEnd
    r.PasteAndFormat wdFormatSurroundingFormattingWithEmphasis
    r.Style = styleName
    Set ImportWithStyle = newDoc.Paragraphs.Last
End Function

Этот метод работает, но имеет два недостатка:

• он использует бумагу для печати и может отвлекать пользователя, удаляя его содержимое
• требуется гораздо больше времени для завершения

Answer 1

Пожалуйста, взгляните на ответ ниже, прежде чем ваш код поступит в производство / распространение. Есть некоторые важные последствия для выбора, сделанного во всех других ответах, представленных до сих пор https://stackoverflow.com/a/51756686/10173250

Answer 2

После долгих экспериментов я наконец написал эту функцию, которая работает:

' Import a paragraph from a document to another, specifying the style
'   srcPar: source paragraph to copy
'   newDoc: document where to import the paragraph
'   styleName: name of the style to apply
'   boldToStyleName (optional): if specified, find bold text in the paragraph, and apply the specified style (of type character style)
'   italicToStyleName (optional): if specified, find italic text in the paragraph, and apply the specified style (of type character style)
'   applyBullet (optional): if true, apply bulleted list to the paragraph before applying the style (to convert list artifacts in the text to word list artifacts)
'   applyOutline (optional): if true, apply outlining to the paragraph before applying the style (to convert list artifacts in the text to word list artifacts)
'   applyRoman (optional): if true, apply roman list to the paragraph before applying the style (to convert list artifacts in the text to word list artifacts)
'   applyAlpha (optional): if true, apply alpha list to the paragraph before applying the style (to convert list artifacts in the text to word list artifacts)
'   applyNumbered (optional): if true, apply numbered list to the paragraph before applying the style (to convert list artifacts in the text to word list artifacts)
'   keepEmphasisParagraphLevel (optional): if true (default), preserve bold and italic at character level and paragraph level
Public Function ImportWithStyle( _
    srcPar As Paragraph, _
    newDoc As Document, _
    styleName As String, _
    Optional boldToStyleName As String, _
    Optional italicToStyleName As String, _
    Optional applyBullet As Boolean = False, _
    Optional applyOutline As Boolean = False, _
    Optional applyRoman As Boolean = False, _
    Optional applyAlpha As Boolean = False, _
    Optional applyNumbered As Boolean = False, _
    Optional keepEmphasisParagraphLevel As Boolean = True _
    ) As Paragraph
    Dim newPar As Paragraph
    Dim r As Range
    Dim styleToApply As style
    Set styleToApply = newDoc.Styles(styleName) ' find the style to apply. The style must exists

    ' get the end of the document range
    Set r = newDoc.Content
    r.Collapse direction:=WdCollapseDirection.wdCollapseEnd

    ' inject the formatted text from the source paragraph
    r.FormattedText = srcPar.Range.FormattedText


    ' apply list template from the target style.

    If applyBullet Then
        r.ListFormat.ApplyBulletDefault
    ElseIf applyNumbered Or applyRoman Or applyAlpha Then  ' Roman is a kind of numbering
        r.ListFormat.ApplyNumberDefault
    ElseIf applyOutline Then
        r.ListFormat.ApplyOutlineNumberDefault
    End If


    ' apply yhe style
    r.style = styleToApply
    Set newPar = newDoc.Paragraphs(newDoc.Paragraphs.Count - 1)


    ' replace bold text format by a character style
    If boldToStyleName <> "" Then
        With newPar.Range.Find
            .ClearFormatting
            .Font.Bold = True
            .Format = True
            With .replacement
                .ClearFormatting
                .style = newDoc.Styles(boldToStyleName)
            End With
            .Execute Replace:=wdReplaceAll
        End With
    End If
    ' replace italic text format by a character style
    If italicToStyleName <> "" Then
        With newPar.Range.Find
            .ClearFormatting
            .Font.Italic = True
            .Format = True
            With .replacement
                .ClearFormatting
                .style = newDoc.Styles(italicToStyleName)
            End With
            .Execute Replace:=wdReplaceAll
        End With
    End If
    With srcPar.Range
        ' If only part of the text is bold, Bold property is wdUndefined. In this case we don't apply bold
        If keepEmphasisParagraphLevel And .Bold <> wdUndefined And .Bold = True Then newPar.Range.Bold = True
        ' same for italic
        If keepEmphasisParagraphLevel And .Italic <> wdUndefined And .Italic Then newPar.Range.Italic = True
    End With
    ' returns the newly created paragraph
    Set ImportWithStyle = newPar
End Function