Question

问题是有一个下拉列表，我可以从中选择名称，我需要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

Answer 1

假设您指的是一个字段，您可以在其中选择Insert-＆gt; Quick Parts-＆gt;字段 - ＆gt;文件自动化。

如果是，并且

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

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

1 个答案: