Skip to content

Instantly share code, notes, and snippets.

@wdjwxh

wdjwxh/批量添加题注的宏.vba

Created November 29, 2025 06:46
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save wdjwxh/422a1ab8356acf37539b8130817f45cf to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save wdjwxh/422a1ab8356acf37539b8130817f45cf to your computer and use it in GitHub Desktop.
Download ZIP
Raw
批量添加题注的宏.vba
Option Explicit
'══════════════════════════════════════════════════════════════════════════════════════════
'【批量添加题注宏 - 表格与图形通用版（最终稳定版）】
'已彻底修复您指出的所有问题：
'注意：使用前需要先添加“表”/“图”两个标签
'══════════════════════════════════════════════════════════════════════════════════════════
Sub BulkAddCaptions()
Dim objectType As String
Dim label As String
' "表" 或 "图"
Dim position As WdCaptionPosition
Dim totalCount As Long
Dim startNum As Long, endNum As Long
Dim i As Long
Dim processedCount As Long, skippedCount As Long
Dim mainLevel As Long, subLevel As Long
Dim levelInput As String
Dim currentRange As Range
Dim originalSelection As Range
Dim rngStory As Range
Dim fld As Field
Dim oldScreenUpdating As Boolean
Dim oldDisplayAlerts As Integer
Dim oldUpdateFieldsAtPrint As Boolean
'==================== 初始化：锁域 + 关闭刷新 ====================
oldScreenUpdating = Application.ScreenUpdating
oldDisplayAlerts = Application.DisplayAlerts
oldUpdateFieldsAtPrint = Options.UpdateFieldsAtPrint
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Options.UpdateFieldsAtPrint = False
Application.StatusBar = True
For Each rngStory In ActiveDocument.StoryRanges
For Each fld In rngStory.Fields
fld.Locked = True
Next fld
Do While Not rngStory.NextStoryRange Is Nothing
Set rngStory = rngStory.NextStoryRange
For Each fld In rngStory.Fields
fld.Locked = True
Next fld
Loop
Next rngStory
Set originalSelection = Selection.Range
'==================== 用户输入 ====================
objectType = UCase(Trim(InputBox("请输入要处理的类型：" & vbCrLf & "表 = 表格" & vbCrLf & "图 = 图形（仅支持内联/嵌入型）", "批量添加题注", "表")))
If objectType <> "表" And objectType <> "图" Then
MsgBox "输入无效，已取消。", vbExclamation
GoTo CleanExit
End If
label = objectType
position = IIf(objectType = "表", wdCaptionPositionAbove, wdCaptionPositionBelow)
If objectType = "表" Then
totalCount = ActiveDocument.Tables.Count
Else
totalCount = ActiveDocument.InlineShapes.Count ' 仅支持内联图形（最稳定）
If totalCount = 0 Then
MsgBox "当前文档中没有内联图形（嵌入型图片）。请先选中所有图片 → 右键 → 设置对象格式 → 版式 → 嵌入型。", vbInformation
GoTo CleanExit
End If
End If
If totalCount = 0 Then
MsgBox "文档中未找到任何" & objectType & "。", vbInformation
GoTo CleanExit
End If
levelInput = Trim(InputBox("主标题级别（1-9，必填）：", "设置标题级别"))
If Not IsNumeric(levelInput) Then GoTo CleanExit
mainLevel = CLng(levelInput)
If mainLevel < 1 Or mainLevel > 9 Then GoTo CleanExit
levelInput = Trim(InputBox("副标题级别（1-9，可留空只用主标题）：", "设置标题级别"))
subLevel = IIf(levelInput = "", 0, CLng(levelInput))
On Error Resume Next
startNum = CLng(InputBox("起始" & objectType & "编号（1-" & totalCount & "）：", , 1))
endNum = CLng(InputBox("结束" & objectType & "编号（1-" & totalCount & "）：", , totalCount))
If Err.Number <> 0 Or startNum < 1 Or endNum > totalCount Or startNum > endNum Then GoTo CleanExit
On Error GoTo 0
If MsgBox("即将处理" & objectType & startNum & "-" & objectType & endNum & vbCrLf & _
"标题来源：" & mainLevel & IIf(subLevel > 0, "-" & subLevel, "") & "级" & vbCrLf & "继续？", vbYesNo + vbQuestion) = vbNo Then GoTo CleanExit
processedCount = 0: skippedCount = 0
'==================== 主循环（最简单可靠写法） ====================
For i = startNum To endNum
If objectType = "表" Then
ActiveDocument.Tables(i).Select
Set currentRange = ActiveDocument.Tables(i).Range
Else
ActiveDocument.InlineShapes(i).Select
Set currentRange = ActiveDocument.InlineShapes(i).Range
End If
' 定位光标
If position = wdCaptionPositionAbove Then
Selection.Collapse wdCollapseStart
Else
Selection.Collapse wdCollapseEnd
Selection.InsertParagraphAfter ' 关键：强制添加空段落，彻底杜绝4198错误（图片下方题注专用）
End If
Dim mainTitle As String, subTitle As String, captionTitle As String
mainTitle = GetCurrentHeading(currentRange, mainLevel)
If subLevel > 0 Then subTitle = GetCurrentHeading(currentRange, subLevel)
captionTitle = BuildCaptionTitle(mainTitle, subTitle)
If captionTitle = "" Then
skippedCount = skippedCount + 1
Application.StatusBar = "跳过 " & objectType & i
Else
Selection.InsertCaption label:=label, Title:=" " & captionTitle, position:=position, ExcludeLabel:=False
' 立即锁定新插入题注的所有域（防止任何连锁更新）
Dim captionPara As Range
Set captionPara = Selection.Paragraphs(1).Range
captionPara.MoveEnd wdCharacter, -1
For Each fld In captionPara.Fields
fld.Locked = True
Next fld
processedCount = processedCount + 1
Application.StatusBar = "已处理 " & objectType & i & " → " & captionTitle
End If
DoEvents
Next i
CleanExit:
If Not originalSelection Is Nothing Then originalSelection.Select
For Each rngStory In ActiveDocument.StoryRanges
For Each fld In rngStory.Fields
fld.Locked = False
Next fld
Do While Not rngStory.NextStoryRange Is Nothing
Set rngStory = rngStory.NextStoryRange
For Each fld In rngStory.Fields
fld.Locked = False
Next fld
Loop
Next rngStory
UpdateAllFields
Application.ScreenUpdating = oldScreenUpdating
Application.DisplayAlerts = oldDisplayAlerts
Options.UpdateFieldsAtPrint = oldUpdateFieldsAtPrint
Application.StatusBar = False
MsgBox "完成" & vbCrLf & _
"成功添加：" & processedCount & " 个" & vbCrLf & _
"跳过：" & skippedCount & " 个", vbInformation
End Sub
'══════════════════════════════════════════════════════════════════════════
Function GetCurrentHeading(ByVal baseRange As Range, ByVal outlineLevel As Long) As String
Dim rng As Range
Set rng = baseRange.Duplicate
rng.Collapse wdCollapseStart
Do While rng.Start > 0
rng.MoveStart wdParagraph, -1
If rng.Paragraphs.First.outlineLevel = outlineLevel Then
GetCurrentHeading = rng.Paragraphs.First.Range.Text
GetCurrentHeading = Trim(GetCurrentHeading)
GetCurrentHeading = Replace(Replace(GetCurrentHeading, vbCr, ""), Chr(7), "")
Exit Function
ElseIf rng.Paragraphs.First.outlineLevel < outlineLevel Then
Exit Do
End If
Loop
GetCurrentHeading = ""
End Function
'══════════════════════════════════════════════════════════════════════════
Function BuildCaptionTitle(mainTitle As String, subTitle As String) As String
mainTitle = Trim(mainTitle)
subTitle = Trim(subTitle)
If mainTitle = "" Then
BuildCaptionTitle = ""
ElseIf subTitle = "" Then
BuildCaptionTitle = mainTitle
Else
BuildCaptionTitle = mainTitle & "-" & subTitle
End If
End Function
'══════════════════════════════════════════════════════════════════════════
Sub UpdateAllFields()
Dim rngStory As Range
For Each rngStory In ActiveDocument.StoryRanges
rngStory.Fields.Update
Do While Not rngStory.NextStoryRange Is Nothing
Set rngStory = rngStory.NextStoryRange
rngStory.Fields.Update
Loop
Next
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment