what is the correct way to copy text from one document to another?

I want to copy the content of a word document to another, with replacing source styles by new ones (basing on a text parsing).

I'm struggling with the method to add a new paragraph with a specific text and style.

Here is my function :

'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

This method is actually adding the text to my document, but the styles are not applied correctly. It seems the styles is applied to the previous paragraph, and not the newly created.

Especially, the line newPar.Range.Text = srcPar.Range.Text has a strange behavior. If srcPar.Range.Text equalsMy text, after the call, newPar.Range.Text remains empty.

I'm not sure that I'm using correctly the ranges and paragraphs objects. Thanks in advance for the help.

FYI, here is how I create the new document :

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

And my CopyAndTransformParagraph function. Its target is to parse text from source to apply the correct style :

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

[Edit] I tried another method :

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

This method seems to work, but have two drawbacks :

• it uses the press paper and can disturb the user by removing its content
• it takes far more times to complete

---

After a lot of experiments, I finally wrote this function, which is working :

' 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

---

Please take a look at the answer below before your code goes to production/distribution. There are some important implications to the choices made in all other answers provided so far https://stackoverflow.com/a/51756686/10173250