如何使用vba将一个Word文档的内容复制到另一个Word文档的末尾？

时间：2019-08-09 17:30:15

标签： excel vba ms-word

我的项目的目标：

我希望能够复制一个文档的内容并将该选择附加到另一文档的末尾。

它的作用 ... （这只是背景信息，所以您了解我为什么要这样做）：

我正在尝试动态生成一个文档，其中引用了有关产品所涉及的不同零件和材料的各种信息。

文档本身具有一致的格式，我已经分解并分成两个文档。第一个包含一堆需要手动输入的数据，在这里我要附加所有其他内容。第二个包含大约十二个自定义字段，这些字段是从VBA中的excel电子表格更新的。对于单个零件和单个文档，这可以按我的要求进行工作（我的基本情况）。但是我的问题是一个项目有多个部分。

问题：

对于多个部分，我必须将信息存储在一个数组中，该数组的大小会随着添加的每个其他部分而动态变化。当某人添加了所有必要的部分后，他们可以选择一个名为“创建报价”的按钮。

创建报价会运行一个过程，该过程创建/打开上述两个模板文档的单独副本（保存在我的计算机上）。然后，它遍历零件数组并更新第二个文档中的所有自定义字段（没有问题）。现在，我只需要将第二个文档的内容附加到第一个文档的末尾即可。

我想要什么：

理想地，我的过程将继续遍历数组的每个部分-更新自定义字段，复制然后粘贴更新的文本，重复...直到每个部分都包含在新生成的报价中。

我尝试过的事情-此代码可以在我的生成报价过程中找到

我已经尝试了有类似问题的人提供的许多示例和建议，但是我不知道是否是因为我使用的是excel文档，但是他们的许多解决方案对我来说都行不通。

这是我最近的尝试，发生在for循环的每次迭代之后 

        wrdDoc2.Fields.Update 'Update all the fields in the format document
        wrdDoc2.Activate

        Selection.WholeStory ' I want to select the entire document
        Selection.Copy ' Copy the doc

        wrdDoc1.Activate ' Set focus to the target document

        Selection.EndKey wdStory ' I want the selection to be pasted to the end of the document
        Selection.PasteAndFormat wdPasteDefault

QUOTE程序-我只包含了一些我要更新的字段，因为没有必要全部显示它们 

Private Sub quote_button_Click()

On Error GoTo RunError

    Dim wrdApp1, wrdApp2 As Word.Application
    Dim wrdDoc1, wrdDoc2 As Word.Document

    Set wrdApp1 = CreateObject("Word.Application")
    Set wrdApp2 = CreateObject("Word.Application")

    wrdApp1.Visible = True
    wrdApp2.Visible = True

    Set wrdDoc1 = wrdApp1.Documents.Add(Template:="C:\MWES\AQT_v1.1(start).docm", NewTemplate:=False, DocumentType:=0)
    Set wrdDoc2 = wrdApp2.Documents.Add(Template:="C:\MWES\AQT_v2.1(format).docm", NewTemplate:=False, DocumentType:=0)

    Dim propName As String

    For i = LBound(part_array, 1) To UBound(part_array, 1)
        For Each prop In wrdDoc2.CustomDocumentProperties

            propName = prop.name

            ' Looks for and sets the property name to custom values of select properties
            With wrdDoc2.CustomDocumentProperties(propName)
                Select Case propName
                    Case "EST_Quantity"
                        .value = part_array(i, 0) ' "QTY" ' Sheet1.Cells(1, 3) 'NA

                    Case "EST_Metal_Number"
                        .value = part_array(i, 1) ' "METAL_#" ' Sheet1.Cells(2, 3) 'NA"

                    Case "EST_Metal_Name"
                        .value = part_array(i, 2) ' "METAL_N" ' Sheet1.Cells(5, 2)

                End Select

            End With

        Next prop ' Iterates until all the custom properties are set

        wrdDoc2.Fields.Update 'Update all the fields in the format document
        wrdDoc2.Activate

        Selection.WholeStory ' I want to select the entire document
        Selection.Copy ' Copy the doc

        wrdDoc1.Activate ' Set focus to the target document

        Selection.EndKey wdStory ' I want the selection to be pasted to the end of the document
        Selection.PasteAndFormat wdPasteDefault

    Next i ' update the document for the next part

RunError: ' Reportd any errors that might occur in the system

    If Err.Number = 0 Then
        Debug.Print "IGNORE ERROR 0!"

    Else
        Dim strError As String
        strError = "ERROR: " & Err.Number & vbCrLf & Err.Description & vbCrLf & Erl
        MsgBox strError
        Debug.Print strError & " LINE: " & Erl

    End If

End Sub

我很抱歉这太长了。让我知道是否有任何混淆或您可能需要澄清。我想我包括了一切。

1 个答案:

答案 0 :(得分：2)

我认为您已经接近了，所以这里有一些评论和一个例子。

首先，您要打开两个单独的MS Word Application对象。您只需要一个。实际上，由于您试图从一个Word应用程序复制到另一个应用程序中打开的文档，复制/粘贴可能失败。 （相信我，我已经看到了类似这样的怪异的东西。）下面的示例演示了如何仅通过打开一个应用程序实例来做到这一点。

Dim mswApp As Word.Application
Set mswApp = AttachToMSWordApplication()   'more on this function below...

Dim doc1 As Word.Document
Dim doc2 As Word.Document
Set doc1 = mswApp.Documents.Open("C:\Temp\combined.docx")
Set doc2 = mswApp.Documents.Open("C:\Temp\control.docx")

尽管我不经常为Word编写代码，但我发现有很多不同的方法可以使用不同的对象或属性来获得相同的内容。这始终是混乱的根源。

基于this answer（过去对我来说效果很好），然后我设置了源和目标范围以执行“复制”：

Dim destination As Word.Range
Dim source As Word.Range
Set source = doc1.Content
Set destination = doc2.Content
destination.Collapse Direction:=Word.wdCollapseEnd
destination.FormattedText = source

以下是整个模块供参考：

Option Explicit

Sub AddDocs()
    Dim wordWasRunning As Boolean
    wordWasRunning = IsMSWordRunning()

    Dim mswApp As Word.Application
    Set mswApp = AttachToMSWordApplication()

    Dim doc1 As Word.Document
    Dim doc2 As Word.Document
    Set doc1 = mswApp.Documents.Open("C:\Temp\combined.docx")
    Set doc2 = mswApp.Documents.Open("C:\Temp\control.docx")

    Dim destination As Word.Range
    Dim source As Word.Range
    Set source = doc1.Content
    Set destination = doc2.Content
    destination.Collapse Direction:=Word.wdCollapseEnd
    destination.FormattedText = source

    doc2.Close SaveChanges:=True
    doc1.Close

    If Not wordWasRunning Then
        mswApp.Quit
    End If
End Sub

这是我在示例中使用的几个函数的预期注释。我建立了一组库函数，其中一些可以帮助我访问其他Office应用程序。我将这些模块另存为.bas文件（通过使用VBA编辑器中的“导出”功能）并根据需要导入。因此，如果您想使用它，只需使用纯文本编辑器保存下面的代码（VBA编辑器中不要！），然后将该文件导入您的项目中。

建议的文件名是Lib_MSWordSupport.bas：

Attribute VB_Name = "Lib_MSWordSupport"
Attribute VB_Description = "Variety of support functions operating on MS Word"
Option Explicit

Public Function IsMSWordRunning() As Boolean
Attribute IsMSWordRunning.VB_Description = "quick check to see if an instance of MS Word is running"
    '--- quick check to see if an instance of MS Word is running
    Dim msApp As Object
    On Error Resume Next
    Set msApp = GetObject(, "Word.Application")
    If Err > 0 Then
        '--- not running
        IsMSWordRunning = False
    Else
        '--- running
        IsMSWordRunning = True
    End If
End Function

Public Function AttachToMSWordApplication() As Word.Application
Attribute AttachToMSWordApplication.VB_Description = "finds an existing and running instance of MS Word, or starts the application if one is not already running"
    '--- finds an existing and running instance of MS Word, or starts
    '    the application if one is not already running
    Dim msApp As Word.Application
    On Error Resume Next
    Set msApp = GetObject(, "Word.Application")
    If Err > 0 Then
        '--- we have to start one
        '    an exception will be raised if the application is not installed
        Set msApp = CreateObject("Word.Application")
    End If
    Set AttachToMSWordApplication = msApp
End Function
相关问题
最新问题