wps英文标点转为中文标点 宏脚本

Sub ReplaceEnglishPunctuationToChinese()
' 声明变量
Dim doc As Document
Set doc = ActiveDocument

' 关闭屏幕更新，提升运行速度
Application.ScreenUpdating = False

On Error GoTo ErrorHandler ' 错误处理

' ========== 核心替换逻辑：英文标点 → 中文标点 ==========
' 1. 英文句号 . → 中文句号 。
doc.Content.Find.Execute FindText:=".", ReplaceWith:="。", Replace:=wdReplaceAll
' 2. 英文逗号 , → 中文逗号 ，
doc.Content.Find.Execute FindText:=",", ReplaceWith:="，", Replace:=wdReplaceAll
' 3. 英文问号 ? → 中文问号 ？
doc.Content.Find.Execute FindText:="?", ReplaceWith:="？", Replace:=wdReplaceAll
' 4. 英文感叹号 ! → 中文感叹号 ！
doc.Content.Find.Execute FindText:="!", ReplaceWith:="！", Replace:=wdReplaceAll
' 5. 英文分号 ; → 中文分号 ；
doc.Content.Find.Execute FindText:=";", ReplaceWith:="；", Replace:=wdReplaceAll
' 6. 英文冒号 : → 中文冒号 ：
doc.Content.Find.Execute FindText:=":", ReplaceWith:="：", Replace:=wdReplaceAll
' 7. 英文双引号 " → 中文双引号 “”（需处理成对替换，避免单边）
Call ReplacePairedQuotes(doc, """", "“", "”")
' 8. 英文单引号 ' → 中文单引号 ‘‘’’（需处理成对替换）
Call ReplacePairedQuotes(doc, "'", "‘", "’")
' 9. 英文左括号 ( → 中文左括号 （
doc.Content.Find.Execute FindText:="(", ReplaceWith:="（", Replace:=wdReplaceAll
' 10. 英文右括号 ) → 中文右括号 ）
doc.Content.Find.Execute FindText:=")", ReplaceWith:="）", Replace:=wdReplaceAll
' 11. 英文左方括号 [ → 中文左方括号 【
doc.Content.Find.Execute FindText:="[", ReplaceWith:="【", Replace:=wdReplaceAll
' 12. 英文右方括号 ] → 中文右方括号 】
doc.Content.Find.Execute FindText:="]", ReplaceWith:="】", Replace:=wdReplaceAll
' 13. 英文左大括号 { → 中文左大括号 ｛
doc.Content.Find.Execute FindText:="{", ReplaceWith:="｛", Replace:=wdReplaceAll
' 14. 英文右大括号 } → 中文右大括号 ｝
doc.Content.Find.Execute FindText:="}", ReplaceWith:="｝", Replace:=wdReplaceAll
' 15. 英文小于号 < → 中文小于号 ＜
doc.Content.Find.Execute FindText:="<", ReplaceWith:="＜", Replace:=wdReplaceAll
' 16. 英文大于号 > → 中文大于号 ＞
doc.Content.Find.Execute FindText:=">", ReplaceWith:="＞", Replace:=wdReplaceAll

' 恢复屏幕更新
Application.ScreenUpdating = True
MsgBox "英文标点已全部替换为中文标点！", vbInformation, "替换完成"

Exit Sub

ErrorHandler:
' 出错时恢复屏幕更新并提示
Application.ScreenUpdating = True
MsgBox "替换过程中出现错误：" & Err.Description, vbCritical, "错误"
End Sub

' 辅助函数：处理成对引号的替换（避免单边替换）
Sub ReplacePairedQuotes(doc As Document, englishQuote As String, chineseLeft As String, chineseRight As String)
Dim findRange As Range
Dim replaceCount As Integer
Dim isLeft As Boolean

Set findRange = doc.Content
replaceCount = 0
isLeft = True ' 标记当前是否替换为左引号

With findRange.Find
.ClearFormatting
.Text = englishQuote
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindStop ' 找到末尾停止
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

' 逐个替换引号，交替使用左右引号
Do While .Execute
replaceCount = replaceCount + 1
If isLeft Then
findRange.Text = chineseLeft
Else
findRange.Text = chineseRight
End If
isLeft = Not isLeft ' 切换左右标记
findRange.Collapse wdCollapseEnd ' 折叠范围，继续查找下一个
Loop
End With
End Sub