VBA在.dotm模板运行正常 新建.docx时内容控件退出事件不触发

功能失效和最初Word 97格式的历史操作没有关系，核心是两个代码逻辑错误：

• 第一，ThisDocument引用对象错误。VBA中这个关键字永远指向代码本身存储的宿主文档，也就是你写代码的.dotm模板。你直接在模板内测试时，当前编辑的对象就是.dotm本身，所以引用匹配、功能正常。但基于模板新建.docx文档后，你实际操作的是新生成的docx文件，代码里所有ThisDocument依然指向后台加载的.dotm模板，根本不会操作当前docx内的内容控件。
• 第二，事件触发范围错误。你使用的Document_ContentControlOnExit是文档级事件，只有当代码所属的文档（即.dotm模板）为当前活动编辑窗口时，退出内容控件的动作才会触发事件。你在新docx内操作时，活动窗口是docx文件，这个事件压根不会启动。
  补充说明：.docx格式本身不支持存储VBA宏，所以你的宏只能保留在.dotm模板中运行，无法嵌入到生成的docx文件里。

1. 打开你的.dotm模板，按Alt+F11进入VBA编辑器
2. 不要把事件写在ThisDocument模块中，先插入一个类模块，在属性窗口将类模块名称改为clsAppEvents，在类模块中粘贴以下代码：

Option Explicit
Public WithEvents app As Word.Application
Private runOnce As Boolean

Private Sub app_DocumentContentControlOnExit(ByVal Doc As Document, ByVal ContentControl As ContentControl, Cancel As Boolean)
    ' 仅处理挂载了当前模板的文档，避免影响其他打开的Word文件
    If Doc.AttachedTemplate <> ThisDocument Then Exit Sub
    
    Dim i As ContentControl
    Dim cc As ContentControl
    On Error Resume Next
    Set i = Doc.SelectContentControlsByTag("Rev Table").Item(1)
    On Error GoTo 0
    If i Is Nothing Then Exit Sub
    
    Select Case ContentControl.Title
    Case "Client Logo"
        If runOnce = True Then
            runOnce = False
            Exit Sub
        Else
            HeadLogoUpdate Doc
            runOnce = True
        End If
       
    Case "Project_num"
        For Each cc In Doc.SelectContentControlsByTag("Doc_num")
            cc.LockContents = False
            cc.Range.Text = Doc.SelectContentControlsByTitle("Project_num").Item(1).Range.Text
            cc.LockContents = True
        Next cc
       
        For Each cc In Doc.SelectContentControlsByTitle("Head_Project_num")
            cc.LockContents = False
            cc.Range.Text = Doc.SelectContentControlsByTitle("Project_num").Item(1).Range.Text
            cc.LockContents = True
        Next cc
       
    Case "Client_Name"
        For Each cc In Doc.SelectContentControlsByTitle("Head_Client_Name")
            cc.LockContents = False
            cc.Range.Text = Doc.SelectContentControlsByTitle("Client_Name").Item(1).Range.Text
            cc.Range.Case = wdUpperCase
            cc.LockContents = True
        Next cc
       
    Case "Project_Name"
        For Each cc In Doc.SelectContentControlsByTitle("Head_Project_Name")
            cc.LockContents = False
            cc.Range.Text = Doc.SelectContentControlsByTitle("Project_Name").Item(1).Range.Text
            cc.Range.Case = wdUpperCase
            cc.LockContents = True
        Next cc
       
    Case "Rev. No."       
        For Each cc In Doc.SelectContentControlsByTitle("Head_Rev")
            cc.LockContents = False
            If i.RepeatingSectionItems.Count > 1 Then
                cc.Range.Text = Doc.SelectContentControlsByTitle("Rev. No.").Item(i.RepeatingSectionItems.Count).Range.Text
            Else
                cc.Range.Text = Doc.SelectContentControlsByTitle("Rev. No.").Item(1).Range.Text
            End If
            cc.LockContents = True
        Next cc
    Case "Date"
        For Each cc In Doc.SelectContentControlsByTitle("Head_Date")
            cc.LockContents = False
            If i.RepeatingSectionItems.Count > 1 Then
                cc.Range.Text = Doc.SelectContentControlsByTitle("Date").Item(i.RepeatingSectionItems.Count - 1).Range.Text
            Else
                cc.Range.Text = Format(Doc.SelectContentControlsByTitle("Date").Item(1).Range.Text, "yyyy/MM/dd")
            End If
            cc.LockContents = True
        Next cc
    End Select
    ActiveWindow.ActivePane.View.Type = wdPrintView
lbl_Exit:
  Exit Sub
End Sub

Sub HeadLogoUpdate(Doc As Document)
    Dim cc As ContentControl
    Dim CLheight As Long, CLwidth As Long, HCLheight As Long, ScaleHeight As Long
    Dim n As Integer
   
    n = 0
    HCLheight = 0.9
    HCLheight = HCLheight / Application.PointsToCentimeters(1)
   
    On Error Resume Next
    CLheight = Doc.SelectContentControlsByTitle("Client Logo").Item(1).Range.InlineShapes(1).Height
    CLwidth = Doc.SelectContentControlsByTitle("Client Logo").Item(1).Range.InlineShapes(1).Width
    If Err.Number <> 0 Then
        Err.Clear
        Exit Sub
    End If
    On Error GoTo 0
    
    ScaleHeight = HCLheight * 100 / CLheight
   
    Doc.SelectContentControlsByTitle("Client Logo")(1).Range.Copy
   
    For Each cc In Doc.SelectContentControlsByTitle("Head Client Logo")
        n = n + 1
        If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
            ActiveWindow.Panes(2).Close
        End If
        If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow.ActivePane.View.Type = wdOutlineView Then
            ActiveWindow.ActivePane.View.Type = wdPrintView
        End If
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
       
        Doc.SelectContentControlsByTitle("Head Client Logo").Item(n).Range.Paste
        Doc.SelectContentControlsByTitle("Head Client Logo").Item(n).Range.InlineShapes(1).LockAspectRatio = msoTrue
        Doc.SelectContentControlsByTitle("Head Client Logo").Item(n).Range.InlineShapes(1).ScaleHeight = ScaleHeight
 
        ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    Next cc
   
End Sub

3. 打开ThisDocument模块，删除原有所有代码，粘贴以下初始化代码，用于模板加载时注册应用级事件：

Option Explicit
Dim oEvents As New clsAppEvents

Private Sub Document_New()
    Set oEvents.app = Word.Application
End Sub

Private Sub Document_Open()
    Set oEvents.app = Word.Application
End Sub

4. 保存.dotm模板，将模板文件放入Word受信任位置避免宏被拦截，之后基于该模板新建docx文档时，内容控件退出同步逻辑即可正常触发。

• 新增了模板匹配判断，仅对挂载了该.dotm的文档生效，不会干扰其他无关Word文档的操作
• 修正了原代码中循环变量和事件参数同名的问题，避免对象指向混乱
• 新增基础容错逻辑，未找到对应控件、未插入Logo时不会直接抛错卡死

内容的提问来源于stack exchange，提问作者Juan-Emil Saayman