一些有用的VBA代码

打开VBA

• 视图->宏->查看宏
• 快捷键：Alt+F11

Word

监听图片粘贴并设为1倍行距

Sub AutoFormatingImage()
    ' 监听粘贴操作
    Application.OnTime When:=Now + TimeValue("00:00:01"), Name:="CheckForPastedImage"
End Sub

Sub CheckForPastedImage()
    Dim pastedImage As InlineShape
    ' 遍历文档中的所有InlineShape
    For Each pastedImage In ActiveDocument.InlineShapes
        ' 检查是否已经标记为Processed
        If Not pastedImage.AlternativeText Like "*Processed" Then
            ' 设置图片所在段落的行距为1
            pastedImage.Range.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
            pastedImage.Range.ParagraphFormat.LineSpacing = 12 ' 12磅等于单倍行距
            pastedImage.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
            ' 在原有的AlternativeText后面添加Processed标记
            pastedImage.AlternativeText = pastedImage.AlternativeText & "Processed"
        End If
    Next pastedImage
    ' 继续监听下一个粘贴操作
    Application.OnTime When:=Now + TimeValue("00:00:01"), Name:="CheckForPastedImage"
End Sub

将图片转换为嵌入式

Sub ConvertToInlineShapeWrap()
On Error Resume Next
Dim P As Shape
Dim arr()
Dim k
k = 0
For Each P In ActiveDocument.Shapes
    ReDim Preserve arr(k)
    arr(k) = P.Name
    k = k + 1
Next
For k = 0 To UBound(arr)
    ActiveDocument.Shapes(arr(k)).ConvertToInlineShape
    
Next
MsgBox "转换【" & k & "】个图片!"
End Sub

在图注编号和正文之间添加全角空格

Sub AddFullWidthSpace()
    Dim doc As Document
    Dim fld As Field
    Dim rng As Range
    Dim fieldCode1 As String
    Dim fieldCode2 As String
    
    Set doc = ActiveDocument
    fieldCode1 = "SEQ 图 \* ARABIC \s 1"
    fieldCode2 = "SEQ 表 \* ARABIC \s 1"
    
    ' Loop through all fields in the document
    For Each fld In doc.Fields
        Set rng = fld.Code
        If InStr(rng.Text, fieldCode1) > 0 Or InStr(rng.Text, fieldCode2) > 0 Then
            ' Move the range to the result of the field
            Set rng = fld.Result
            rng.Collapse Direction:=wdCollapseEnd
            ' Check if the next character is a full-width space
            If Not rng.End = doc.Content.End Then
                rng.MoveEnd wdCharacter, 1
                If rng.Text <> "　" Then
                    rng.Collapse Direction:=wdCollapseEnd
                    rng.InsertAfter "　"
                End If
            End If
        End If
    Next fld
    
    ' Remove multiple full-width spaces
    With doc.Content.Find
        .Text = "　{2,}"
        .Replacement.Text = "　"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
End Sub

将图片（后一段的）题注写入“替换文字”

' 将图片后一段的题注写入“替换文字”
Sub CaptionToAltText()
    Dim doc As Document
    Dim shape As InlineShape
    Dim para As Paragraph
    Dim captionText As String
    
    Set doc = ActiveDocument
    
    For Each shape In doc.InlineShapes
        On Error Resume Next
        ' 获取图片下方的段落
        Set para = shape.Range.Paragraphs(1).Next
        ' 检查段落是否包含图注
        If para.Range.Style = "题注" Then
            captionText = para.Range.Text
            ' 去除段落标记
            captionText = Left(captionText, Len(captionText) - 1)
            shape.AlternativeText = captionText
        End If
        On Error GoTo 0
    Next shape
End Sub

PPT

自动修改图注编号

要求：文本框为图\s*\d+\s*开头。

Sub UpdateFigureNumbersAndCustomFont()
    Dim sld As Slide
    Dim shp As Shape
    Dim figureNumber As Integer
    Dim regex As Object
    Dim matches As Object
    Dim match As Object
    Dim char As TextRange
    Dim updatedCaptions As String
    Dim previousCaption As String
    Dim currentCaption As String
    Dim currentFigureNumber As Integer
    
    Set regex = CreateObject("VBScript.RegExp")
    regex.Global = True
    regex.Pattern = "^(图\s*\d+\s*)"
    
    figureNumber = 1 ' 初始化编号
    currentFigureNumber = figureNumber ' 初始化当前题注的编号
    updatedCaptions = "" ' 初始化更新后的题注字符串
    previousCaption = "" ' 初始化上一个题注的文本
    
    ' 遍历所有幻灯片
    For Each sld In ActivePresentation.Slides
        ' 遍历幻灯片上的所有形状
        For Each shp In sld.Shapes
            ' 检查形状是否有文本框
            If shp.HasTextFrame Then
                ' 使用正则表达式匹配文本
                Set matches = regex.Execute(shp.TextFrame.TextRange.text)
                If matches.Count > 0 Then
                    Set match = matches(0)
                    ' 移除题注中的“图 x”部分
                    currentCaption = Replace(shp.TextFrame.TextRange.text, match.Value, "")
                    ' 检查当前题注是否与上一个题注相同
                    If currentCaption <> previousCaption Then
                        ' 如果不相同，更新当前题注的编号
                        currentFigureNumber = figureNumber
                        figureNumber = figureNumber + 1
                    End If
                    ' 更新编号并保留原有的文本格式
                    With shp.TextFrame.TextRange
                        .Characters(Start:=match.FirstIndex + 1, Length:=match.Length).text = "图 " & currentFigureNumber & " "
                        ' 收集更新后的题注
                        updatedCaptions = updatedCaptions & .text & vbNewLine
                        ' 更新上一个题注的文本
                        previousCaption = currentCaption
                    End With
                    ' 遍历文本框中的每个字符
                    For i = 1 To shp.TextFrame.TextRange.Length
                        Set char = shp.TextFrame.TextRange.Characters(i, 1)
                        If AscW(char.text) >= &H4E00 And AscW(char.text) <= &H9FFF Then
                            ' 如果字符是中文，则设置字体为“黑体”
                            char.Font.NameFarEast = "黑体"
                        Else
                            ' 如果字符是英文，则设置字体为“Arial”
                            char.Font.Name = "Arial"
                        End If
                        ' 设置字号为14
                        char.Font.Size = 14
                    Next i
                End If
            End If
        Next shp
    Next sld
    
    ' 显示成功消息和所有更新后的题注
    MsgBox "编号更新成功！中文字体已设置为“黑体”，英文字体为“Arial”，字号为14。以下是所有更新后的题注：" & vbNewLine & updatedCaptions, vbInformation, "题注更新"
End Sub