我希望能够复制一个文档的内容并将该选择附加到另一文档的末尾。
它的作用 ... (这只是背景信息,所以您了解我为什么要这样做):
我正在尝试动态生成一个文档,其中引用了有关产品所涉及的不同零件和材料的各种信息。
文档本身具有一致的格式,我已经分解并分成两个文档。第一个包含一堆需要手动输入的数据,在这里我要附加所有其他内容。第二个包含大约十二个自定义字段,这些字段是从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
我很抱歉这太长了。让我知道是否有任何混淆或您可能需要澄清。我想我包括了一切。
答案 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