VBA操作Word - 技术栈

检查word中的字体情况

vbnet 复制代码

Sub ListAllFontsInDocument()
    Dim doc As Document
    Dim rng As Range
    Dim char As Range
    Dim fontName As String
    Dim uniqueFonts As Collection
    
    ' 初始化集合用于存储唯一字体名称
    Set uniqueFonts = New Collection
    
    ' 获取当前活动文档
    Set doc = ActiveDocument
    
    ' 遍历文档中的每一个字符
    For Each rng In doc.Content.Characters
        ' 获取字符的字体名称
        fontName = rng.Font.Name
        
        ' 检查字体名称是否已经在集合中，如果没有则添加进去
        On Error Resume Next
        uniqueFonts.Add fontName, CStr(fontName)
        On Error GoTo 0
    Next rng
    
    ' 输出所有唯一的字体名称
    Dim item As Variant
    For Each item In uniqueFonts
        Debug.Print item
    Next item
End Sub

删除未使用样式

vbnet 复制代码

Sub 删除文档中未使用的样式()
    Dim doc As Document
    Dim pa As Paragraph
    Dim i As Long
    Dim sty As Style
    Dim dSty As Object
    Dim key
    
    Set dSty = CreateObject("Scripting.Dictionary")
    
    Set doc = ActiveDocument
    
    For Each pa In doc.Paragraphs
        key = pa.Style.NameLocal
        
        Debug.Print key
        If Not dSty.Exists(key) Then
            dSty(key) = True
        End If
    Next pa
    
    For i = doc.Styles.Count To 1 Step -1
        Set sty = doc.Styles(i)
        key = sty.NameLocal
        
        If Not dSty.Exists(key) Then
            On Error Resume Next
            sty.Delete
            On Error GoTo 0
        End If
    Next i
    
    Set doc = Nothing
    Set pa = Nothing
    Set sty = Nothing
    
    MsgBox "完成"
End Sub

选中所有表格

vbnet 复制代码

Sub 选择word中的表格()
Dim t As Table
an = MsgBox("即将选择选区内所有表格，若无选区，则选择全文表格。", vbYesNo, "提示")
If an - 6 Then Exit Sub
Set rg = IIf(Selection.Type = wdSelectionIP, ActiveDocument.Content, Selection.Range)
ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
For Each t In rg.Tables
    t.Range.Editors.Add wdEditorEveryone
Next
ActiveDocument.SelectAllEditableRanges wdEditorEveryone
ActiveDocument.DeleteAllEditableRanges wdEditorEveryone
End Sub

vbnet 复制代码

 ' 移除正则匹配的字符串中的指定字符
Public Sub RemoveChars()
    Dim rng As Range
    Set rng = ActiveDocument.Content ' 或者指定特定的Range对象

    With rng.Find
        .ClearFormatting
        .Text = "[A-Z][-][0-9]?{1,10}[。]"
        .Forward = True
        .MatchWildcards = True

        Do While .Execute
            Dim matchText As String
            matchText = rng.Text

            ' 去除matchText中的"x"字符
            matchText = Replace(matchText, "。", "")

            ' 将修改后的文本替换回原文档
            rng.Text = matchText

            ' 移动查找范围到下一个匹配项
            rng.Collapse wdCollapseEnd
        Loop
    End With
End Sub