1
我想复制一个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
这种方法似乎是工作，但有两个缺点：
- 它使用印刷纸，可以通过删除其内容来干扰用户
- 要花多得多的时间来完成