Word2016如何通过名称调用内容控件实现选择项自动填充文本

前置配置步骤 #

• 先调出开发工具选项卡：打开Word，点「文件」-「选项」-「自定义功能区」，在右侧主选项卡列表里找到「开发工具」打勾，点确定就能在顶部菜单栏看到开发工具入口
• 插入需要的内容控件：在开发工具选项卡里，按需插入下拉列表内容控件、复选框内容控件，以及用来放自动填充内容的纯文本/富文本内容控件
• 给每个控件设置唯一标题：点选任意控件，点开发工具栏里的「属性」按钮，在「标题」栏填唯一的名称，不要重名。比如下拉框可以叫客户选择，对应放填充内容的文本控件可以叫客户详情区，复选框分别叫服务条款、保密条款即可，全程不需要记控件ID
• 下拉选项配置：下拉控件的属性里添加选项时，「显示名称」填你要在下拉列表里看到的文字，「值」填选中后要自动填充的长文本，文本里需要换行的位置直接输入|，代码会自动识别替换为Word换行
• 复选框对应的填充文本直接在代码里对应填写即可，不需要在控件属性里额外配置

可直接粘贴使用的VBA代码 #

按Alt+F11快捷键打开VBA编辑器，在左侧项目列表里双击当前文档下的ThisDocument，把下面的代码完整粘贴到右侧编辑区，之后保存文档时选择「启用宏的Word文档（*.docm）」格式，打开文档时点击顶部安全提示栏的「启用内容」即可正常使用。

Private Sub Document_ContentControlOnExit(ByVal ContentControl As ContentControl, Cancel As Boolean)
    Dim cc As ContentControl
    Dim fillText As String
    Dim i As Long
    
    ' --------------------------
    ' 自定义配置区：按自己的控件名称修改即可
    ' --------------------------
    ' 1. 下拉列表联动逻辑示例
    If ContentControl.Title = "客户选择" Then
        fillText = ""
        For i = 1 To ContentControl.DropdownListEntries.Count
            If ContentControl.DropdownListEntries(i).Text = ContentControl.Range.Text Then
                fillText = Replace(ContentControl.DropdownListEntries(i).Value, "|", Chr(11))
                Exit For
            End If
        Next
        ' 按标题定位填充目标控件
        Set cc = GetCCByTitle("客户详情区")
        If Not cc Is Nothing Then cc.Range.Text = fillText
    End If
    
    ' 2. 复选框联动逻辑示例
    Dim checkMap As Object
    Set checkMap = CreateObject("Scripting.Dictionary")
    ' 新增复选框就按下面格式加行：checkMap.Add "复选框标题", "勾选后插入的文本"
    checkMap.Add "服务条款", "1. 服务约定：乙方按合同约定的交付标准提供技术服务，甲方按约定节点支付服务费用，服务周期自合同签订日起12个月。" & Chr(11)
    checkMap.Add "保密条款", "2. 保密约定：双方对合作中获取的对方商业信息承担保密责任，保密义务在合同终止后3年内持续有效。" & Chr(11)
    checkMap.Add "违约条款", "3. 违约约定：任意一方违约需向守约方支付合同总金额10%作为违约金，实际损失超出违约金部分按实赔付。" & Chr(11)
    
    ' 自动拼接所有勾选的复选框对应文本
    If ContentControl.Type = wdContentControlCheckBox Then
        fillText = ""
        Dim key As Variant
        For Each key In checkMap.Keys
            Set cc = GetCCByTitle(CStr(key))
            If Not cc Is Nothing Then
                If cc.Checked = True Then fillText = fillText & checkMap(key)
            End If
        Next
        ' 按标题定位复选框内容的填充目标
        Set cc = GetCCByTitle("条款填充区")
        If Not cc Is Nothing Then cc.Range.Text = fillText
    End If
    ' --------------------------
    ' 自定义配置区结束，无特殊需求不要修改以下代码
    ' --------------------------
End Sub

' 通用工具函数：按控件标题查找对应控件，无需匹配控件ID
Private Function GetCCByTitle(titleText As String) As ContentControl
    Dim cc As ContentControl
    For Each cc In ActiveDocument.ContentControls
        If cc.Title = titleText Then
            Set GetCCByTitle = cc
            Exit Function
        End If
    Next
    Set GetCCByTitle = Nothing
End Function

自定义修改说明 #

• 所有控件只要保证设置的标题和代码里写的名称完全一致（注意区分中英文符号、前后空格），就能正常触发联动，增删其他控件不会影响现有逻辑
• 需要新增下拉联动规则时，直接照着代码里「客户选择」的下拉逻辑复制一段，修改对应的下拉控件标题、填充目标控件标题即可
• 需要新增复选框选项时，直接在checkMap里按示例格式新增一行，填写对应复选框标题和要插入的文本即可
• 代码完全兼容Microsoft Office 2016版本，不需要安装额外插件或工具

内容的提问来源于stack exchange，提问作者Daniel