如何使用BuildingBlockEntry().插入方法在Word文档与Excel VBA?

Question

大部分代码是从《如何使用VBA将Excel数据插入到Word中，并将其导出为PDF?》

是否有任何方法通过Excel VBA在Word文档中插入quickparts-buildingblock中的文本?

这将冻结Excel:

wordDoc.Application.Templates(...).BuildingBlockEntries("test").Insert Where:=Selection.Range, RichText:=True

代码:

Sub Generate()
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim wsGenerator As Worksheet
Set wsGenerator = wb.Sheets("List")
Dim wordApp As Word.Application
Set wordApp = New Word.Application
Dim wordDoc As Word.Document
Dim name1, name2, name3, name4 As String
Dim n, j As Integer
n = wsGenerator.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
For j = 2 To n
Set wordDoc = wordApp.Documents.Open("C:Users" & Environ("username") & "DesktopExcelTestTemplate.docx")

wordApp.Templates.LoadBuildingBlocks
name1 = wsGenerator.Range("A" & j).Value
name2 = wsGenerator.Range("B" & j).Value
name3 = wsGenerator.Range("C" & j).Value
name4 = wsGenerator.Range("D" & j).Value
If name4 = "" Then
wordDoc.Application.Templates( _
Environ("AppData") & "MicrosoftDocument Building Blocks104516Building Blocks.dotx" _
).BuildingBlockEntries("test").Insert Where:=Selection.Range, RichText:=True
End If
With wordDoc.Content.Find
.Execute FindText:="<<name1>>", ReplaceWith:=name1, Replace:=wdReplaceAll
.Execute FindText:="<<name2>>", ReplaceWith:=name2, Replace:=wdReplaceAll
.Execute FindText:="<<name3>>", ReplaceWith:=name3, Replace:=wdReplaceAll
.Execute FindText:="<<name4>>", ReplaceWith:=name4, Replace:=wdReplaceAll
End With
wordDoc.ExportAsFixedFormat "C:Users" & Environ("Username") & "DesktopExcelTest" & wsGenerator.Range("A" & j).Value & " " & wsGenerator.Range("C" & j).Value & ".pdf", _
wdExportFormatPDF
wordDoc.Close (wdDoNotSaveChanges)
Next
End Sub

Answer 1

你的代码有几个问题。

首先，wordDoc.Application将失败，因为Application不是文档的子对象。您已经设置了一个变量，wordApp指向Word Application对象，并且需要使用它。

其次，您只需要加载构建块一次，而不是在循环的每次迭代中。

第三，在VBA中变量声明为:Dim name1, name2, name3, name4 As String将导致只有name4是字符串，而所有的默认数据类型都是Variant。

纠正这些问题后，您的代码将是:

Dim wb As Workbook
Set wb = ActiveWorkbook
Dim wsGenerator As Worksheet
Set wsGenerator = wb.Sheets("List")
Dim wordApp As Word.Application
Set wordApp = New Word.Application
Dim wordDoc As Word.Document
Dim name1 As String, name2 As String, name3 As String, name4 As String
Dim n, j As Integer
n = wsGenerator.Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
'load building blocks
Dim bblockSource As String
bblockSource = Environ("appdata") & "MicrosoftDocument Building Blocks104516Building Blocks.dotx"
wordApp.Templates.LoadBuildingBlocks
For j = 2 To n
Set wordDoc = wordApp.Documents.Open("C:Users" & Environ("username") & "DesktopExcelTestTemplate.docx")

name1 = wsGenerator.Range("A" & j).Value
name2 = wsGenerator.Range("B" & j).Value
name3 = wsGenerator.Range("C" & j).Value
name4 = wsGenerator.Range("D" & j).Value
If name4 = "" Then
wordApp.Templates(bblockSource).BuildingBlockEntries("test").Insert Where:=wordApp.Selection.Range, RichText:=True
End If
With wordDoc.Content.Find
.Execute FindText:="<<name1>>", ReplaceWith:=name1, Replace:=wdReplaceAll
.Execute FindText:="<<name2>>", ReplaceWith:=name2, Replace:=wdReplaceAll
.Execute FindText:="<<name3>>", ReplaceWith:=name3, Replace:=wdReplaceAll
.Execute FindText:="<<name4>>", ReplaceWith:=name4, Replace:=wdReplaceAll
End With
wordDoc.ExportAsFixedFormat "C:Users" & Environ("Username") & "DesktopExcelTest" & wsGenerator.Range("A" & j).Value & " " & wsGenerator.Range("C" & j).Value & ".pdf", _
wdExportFormatPDF
wordDoc.Close (wdDoNotSaveChanges)
Next

你还需要注意，你的代码在你完成后不会关闭Word，这可能会导致Word的多个隐藏实例。