vba word 批量删除批注

Sub 批量删除批注()

'

' 批量删除批注 Macro'

Dim fPk As FileDialog, fName, fType As String, 后缀 As String, t0, 计数

t0 = Timer

Set fPk = Application.FileDialog(msoFileDialogFilePicker)

With fPk

.AllowMultiSelect = True

.InitialFileName = "注意在此处放入需要处理word文件的文件夹地址"

.Show

fType = InputBox("请输入文件类型（支持通配符，如“doc*”）：", "文件类型", "doc*")

If .SelectedItems.Count > 0 Then

For Each fName In .SelectedItems

If fType = "" Then

MsgBox "文件类型为空，将退出程序！", vbInformation, "出错提示"

Exit Sub

Else

后缀 = Right(fName, Len(fName) - InStrRev(fName, "."))

If 后缀 Like fType Then

Call 删除批注(fName)

计数 = 计数 + 1

End If

End If

Next

Else

MsgBox "您未选择文件，将退出程序！", vbInformation, "出错提示"

Exit Sub

End If

End With

Set fPk = Nothing

If 计数 > 0 Then

Debug.Print "完成，共处理了" & 计数 & "个文件。用时" & Timer - t0 & "秒。"

MsgBox "完成，共处理了" & 计数 & "个文件。用时" & Timer - t0 & "秒。"

Else

Debug.Print "完成，没有类型符合要求的文件。用时" & Timer - t0 & "秒。"

MsgBox "完成，没有类型符合要求的文件。用时" & Timer - t0 & "秒。"

End If

End Sub

Sub 删除批注(fName)

Dim aDoc As Document

Application.ScreenUpdating = False

Set aDoc = Documents.Open(fName)

'此处以下写对文件的具体处理过程

If aDoc.ProtectionType = 3 Then

aDoc.Unprotect Password:="3q"

End If

Selection.SetRange Start:=7497, End:=7497

aDoc.DeleteAllComments

Debug.Print "已完成对文件《" & aDoc.FullName & " 》的处理。 "

'此处以上写对文件的具体处理过程

aDoc.Close wdSaveChanges

Application.ScreenUpdating = True

Set aDoc = Nothing

End Sub