从下拉列表中自动填充 Word 中的字段答案

【问题标题】：Auto populate fields in Word from drop down list从下拉列表中自动填充 Word 中的字段
【发布时间】：2016-05-05 09:37:52
【问题描述】：

问题是有一个下拉列表，我可以从中选择姓名，并且我需要 Word 文件中的其他字段填充此人的联系数据。数据来自我设法连接并填充下拉列表的 Excel 文件。我被卡住了，我不知道如何通过选择名称来自动填充字段。目前我在数据库中有 5 条记录，但还会有更多。我已经开始了我的编程冒险，可能我要求的东西很简单，但无论如何，这是我通过搜索大量教程得到的：

Sub Document_Open()
  Application.ScreenUpdating = True

  Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook
  Dim StrWkBkNm As String, StrWkShtNm As String, LRow As Long

  StrWkBkNm = "D:\Users\Magda91\Desktop\filename.xlsx"
  StrWkShtNm = "Sheet1"
  If Dir(StrWkBkNm) = "" Then
    MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
    Exit Sub
  End If
  With xlApp
    'Hide our Excel session
    .Visible = False
    ' Open the workbook
    Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMRU:=False)
    ' Process the workbook.
    With xlWkBk
      If SheetExists(StrWkShtNm) = True Then
        With .Worksheets(StrWkShtNm)

          Dim MyMatrix1(1 To 5, 1 To 5)
          Dim i As Integer, j As Integer 
          For i = 1 To 5 
            For j = 1 To 5 
              MyMatrix1(i, j) = .Cells(i + 1, j).Value
            Next j
          Next i

         ActiveDocument.SelectContentControlsByTitle("TechnicalContactName")(1).DropdownListEntries.Clear
         ActiveDocument.SelectContentControlsByTitle("Position1")(1).DropdownListEntries.Clear
         ActiveDocument.SelectContentControlsByTitle("Phone1")(1).DropdownListEntries.Clear
         ActiveDocument.SelectContentControlsByTitle("Mobile1")(1).DropdownListEntries.Clear
         ActiveDocument.SelectContentControlsByTitle("Email1")(1).DropdownListEntries.Clear
         For i = 1 To 4
           ActiveDocument.SelectContentControlsByTitle("TechnicalContactName")(1).DropdownListEntries.Add _
            Text:=Trim(MyMatrix1(i, 1))
           ActiveDocument.SelectContentControlsByTitle("Position1")(1).DropdownListEntries.Add _
            Text:=Trim(MyMatrix1(i, 2))
           ActiveDocument.SelectContentControlsByTitle("Phone1")(1).DropdownListEntries.Add _
            Text:=Trim(MyMatrix1(i, 3))
           ActiveDocument.SelectContentControlsByTitle("Mobile1")(1).DropdownListEntries.Add _
            Text:=Trim(MyMatrix1(i, 4))
           ActiveDocument.SelectContentControlsByTitle("Email1")(1).DropdownListEntries.Add _
            Text:=Trim(MyMatrix1(i, 5))
         Next

       End With
     Else
       MsgBox "Cannot find the designated worksheet: " & StrWkShtNm, vbExclamation
     End If
     .Close False
   End With
   .Quit
 End With

 ' Release Excel object memory
 Set xlWkBk = Nothing: Set xlApp = Nothing
 Application.ScreenUpdating = True

End Sub

Function SheetExists(SheetName As String) As Boolean
  SheetExists = False
  On Error GoTo NoSuchSheet
  If Len(Sheets(SheetName).Name) > 0 Then SheetExists = True
  NoSuchSheet:
End Function

【问题讨论】：

您需要更具体地了解“字段”的含义。我觉得您的意思是“内容控件”，就像在其他下拉列表中一样？（Word 中的“字段”是一个非常具体的东西，当您将该术语用于其他任何内容时会让人感到困惑。）您真的需要 5 个下拉菜单吗？如果用户应该选择 name，为什么不让其他的作为文本内容控件呢？另请注意，OLE DB 连接比打开工作簿更有效，尤其是在您将拥有大量条目的情况下。工作簿可能需要很长时间才能打开...
你完全正确！现在我有所有的下拉菜单，但我会尝试用文本框来做，它可能会更好。
那么，您目前还好吗，使用纯文本或富文本内容控件？

标签： excel vba ms-word dropdown

【解决方案1】：

假设您指的是一个字段，您将在其中选择“插入”->“快速部件”->“字段”->“文档自动化”。

如果是这样的话

TechnicalContactName 字段为 TechnicalContactName
位置字段为 PositionField
电话字段作为 PhoneField
移动字段作为 MobileField
电子邮件字段作为 EmailField

我还假设您想使用“技术联系人”中的相应职位、电话、手机和电子邮件，而不是每个下拉列表中的不同选择。

一旦选择了技术联系人，然后运行此代码。它也可以分配给您添加到文档中的按钮。

 Sub PopulatingFieldsFromDropDownBox()

      Dim TechnicalContactDropDownList As ContentControl
      Set TechnicalContactDropDownList = ActiveDocument.SelectContentControlsByTitle("TechnicalContactName").Item(1)

      'Getting the selected entry Name
      Dim SelectedTechnicalContact As String
      SelectedTechnicalContact = TechnicalContactDropDownList.Range.Text

      'Getting the Dropdownbox index number for TechnicalContact box
      Dim ListEntryNumber As Long
      For ListEntryNumber = 1 To TechnicalContactDropDownList.DropdownListEntries.Count

           If SelectedTechnicalContact = TechnicalContactDropDownList.DropdownListEntries(ListEntryNumber).Text Then
                Exit For
           End If

      Next ListEntryNumber

      'The Number is brackets needs to be one more that the amount for DropDownLists you have
      'Because the array actually starts at 0
      Dim TechnicalContactArray(5) As Variant

      TechnicalContactArray(1) = ActiveDocument.SelectContentControlsByTitle("TechnicalContactName").Item(1).DropdownListEntries(ListEntryNumber).Text
      TechnicalContactArray(2) = ActiveDocument.SelectContentControlsByTitle("Position1").Item(1).DropdownListEntries(ListEntryNumber).Text
      TechnicalContactArray(3) = ActiveDocument.SelectContentControlsByTitle("Phone1").Item(1).DropdownListEntries(ListEntryNumber).Text
      TechnicalContactArray(4) = ActiveDocument.SelectContentControlsByTitle("Mobile1").Item(1).DropdownListEntries(ListEntryNumber).Text
      TechnicalContactArray(5) = ActiveDocument.SelectContentControlsByTitle("Email1").Item(1).DropdownListEntries(ListEntryNumber).Text

      Dim CurrentField As Field
      For Each CurrentField In ActiveDocument.Fields

           'Sending the Correct data to the various fields
           If InStr(1, CurrentField.Code.Text, "TechnicalContactName") > 0 Then
                CurrentField.Result.Text = TechnicalContactArray(1)
           ElseIf InStr(1, CurrentField.Code.Text, "PositionField") > 0 Then
                CurrentField.Result.Text = TechnicalContactArray(2)
           ElseIf InStr(1, CurrentField.Code.Text, "Phone") > 0 Then
                CurrentField.Result.Text = TechnicalContactArray(3)
           ElseIf InStr(1, CurrentField.Code.Text, "Mobile") > 0 Then
                CurrentField.Result.Text = TechnicalContactArray(4)
           ElseIf InStr(1, CurrentField.Code.Text, "Email") > 0 Then
                CurrentField.Result.Text = TechnicalContactArray(5)
           End If

      Next CurrentField

 End Sub

【讨论】：