1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39
| Private Sub Copy()
Dim newDoc As Document
Dim srcDoc As Document
Set srcDoc = Application.ActiveDocument
Set newDoc = Application.Documents.Add
Dim srcPar As Paragraph ' the paragraph to copy
For Each srcPar In srcDoc.Paragraphs
CopyAndTransformParagraph(srcPar, srcDoc, newDoc)
Next
end sub
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
if Rule1(parText) then
ImportWithStyle(srcPar, srcDoc, newDoc, "Style when rule 1")
elseif
ImportWithStyle(srcPar, srcDoc, newDoc, "Style when rule 2")
else
ImportWithStyle(srcPar, srcDoc, newDoc, "Style when else")
end if
End Function
Private Function ImportWithStyle(srcPar As Paragraph, srcDoc As Document, newDoc As Document, styleName As String) As Paragraph
Dim newPar As Paragraph
Dim r As Range
Set r = newDoc.Content
r.Collapse direction:=WdCollapseDirection.wdCollapseEnd
r.FormattedText = srcPar.Range.FormattedText
r.style = newDoc.Styles(styleName)
Set ImportWithStyle = newDoc.Paragraphs(newDoc.Paragraphs.Count - 1)
End Function |
Partager