Sub ListAllFontsInDocument()Dim doc As Document
Dim rng As Range
DimcharAs Range
Dim fontName AsStringDim uniqueFonts As Collection
' 初始化集合用于存储唯一字体名称Set uniqueFonts =New Collection
' 获取当前活动文档Set doc = ActiveDocument
' 遍历文档中的每一个字符For Each rng In doc.Content.Characters
' 获取字符的字体名称
fontName = rng.Font.Name' 检查字体名称是否已经在集合中,如果没有则添加进去On ErrorResumeNext
uniqueFonts.Add fontName,CStr(fontName)On ErrorGoTo0Next rng
' 输出所有唯一的字体名称Dim item As Variant
For Each item In uniqueFonts
Debug.Print item
Next item
EndSub
删除未使用样式
Sub 删除文档中未使用的样式()Dim doc As Document
Dim pa As Paragraph
Dim i AsLongDim sty AsStyleDim dSty AsObjectDimkeySet dSty = CreateObject("Scripting.Dictionary")Set doc = ActiveDocument
For Each pa In doc.Paragraphs
key= pa.Style.NameLocal
Debug.PrintkeyIfNot dSty.Exists(key)Then
dSty(key)=TrueEndIfNext pa
For i = doc.Styles.Count To1Step-1Set sty = doc.Styles(i)key= sty.NameLocal
IfNot dSty.Exists(key)ThenOn ErrorResumeNext
sty.DeleteOn ErrorGoTo0EndIfNext i
Set doc =NothingSet pa =NothingSet sty =Nothing
MsgBox "完成"EndSub
选中所有表格
Sub 选择word中的表格()Dim t As Table
an = MsgBox("即将选择选区内所有表格,若无选区,则选择全文表格。", vbYesNo,"提示")If an -6ThenExitSubSet 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
EndSub
' 移除正则匹配的字符串中的指定字符PublicSub RemoveChars()Dim rng As Range
Set rng = ActiveDocument.Content ' 或者指定特定的Range对象With rng.Find
.ClearFormatting
.Text="[A-Z][-][0-9]?{1,10}[。]"
.Forward =True
.MatchWildcards =TrueDoWhile .Execute
Dim matchText AsString
matchText = rng.Text' 去除matchText中的"x"字符
matchText = Replace(matchText,"。","")' 将修改后的文本替换回原文档
rng.Text= matchText
' 移动查找范围到下一个匹配项
rng.Collapse wdCollapseEnd
LoopEndWithEndSub