求助：word宏命令；中英文段落标点符号修改

anytoo

需求：
在word一篇文章中；实现2个宏命令；
宏命令1.将选定的内容中：中文标点符号改英文；
宏命令2.将选定的内容中：英文标点符号改中文；


注：
不要全文操作，命令只对选定的内容操作；
分开为2个独立的宏命令
我现在的命令只能批量改英文格式或者中文格式，求大神帮看看。万分感谢。



Sub ToggleInterpunction() '中英文标点互换
Dim ChineseInterpunction() As Variant, EnglishInterpunction() As Variant, myArray1() As Variant, myArray2() As Variant, strFind As String, strRep As String
Dim msgResult As VbMsgBoxResult, N As Byte
'定义一个中文标点的数组对象
ChineseInterpunction = Array("、", "。", "，", "；", "：", "？", "！", "……", "—", "～", "（", "）", "《", "》")
'定义一个英文标点的数组对象
EnglishInterpunction = Array(",", ".", ",", ";", ":", "?", "!", "…", "-", "~", "(", ")", "<", ">")
'提示用户交互的MSGBOX对话框
msgResult = MsgBox("您想中英标点互换吗?按Y将中文标点转为英文标点,按N将英文标点转为中文标点! ", vbYesNoCancel)
Select Case msgResult
Case vbCancel
Exit Sub '如果用户选择了取消按钮,则退出程序运行
Case vbYes '如果用户选择了YES,则将中文标点转换为英文标点
myArray1 = ChineseInterpunction
myArray2 = EnglishInterpunction
strFind = "“(*)”"
strRep = """\1"""
Case vbNo '如果用户选择了NO,则将英文标点转换为中文标点
myArray1 = EnglishInterpunction
myArray2 = ChineseInterpunction
strFind = """(*)"""
strRep = "“\1”"
End Select
Application.ScreenUpdating = False '关闭屏幕更新
For N = 0 To UBound(ChineseInterpunction) '从数组的下标到上标间作一个循环
With ActiveDocument.Content.Find
.ClearFormatting '不限定查找格式
.MatchWildcards = False '不使用通配符
'查找相应的英文标点,替换为对应的中文标点
.Execute findtext:=myArray1(N), replacewith:=myArray2(N), Replace:=wdReplaceAll
End With
Next
With ActiveDocument.Content.Find
.ClearFormatting '不限定查找格式
.MatchWildcards = True '使用通配符
.Execute findtext:=strFind, replacewith:=strRep, Replace:=wdReplaceAll
End With
Application.ScreenUpdating = True '恢复屏幕更新
End Sub

wingh

[Visual Basic] 纯文本查看 复制代码

Sub ReplacePunction()
    Set re = CreateObject("VBScript.RegExp")
    enArr = Array("-", ".", ",", ";", ":", "?", "!", "…", "~", "(", ")", "<", ">")
    cnArr = Array("—", "。", "，", "；", "：", "？", "！", "……", "～", "（", "）", "《", "》")
    enArrCopy = enArr
    enArrCopy(1) = "\\."
    re.Global = True
    re.Pattern = "[\u4e00-\u9fa5]([" & Join(enArrCopy, "") & "])"
    Set Matches = re.Execute(ActiveDocument.Range.Text)
    For Each match In Matches
        punc = match.Submatches.Item(0)
        ActiveDocument.Range(match.FirstIndex + 1, match.FirstIndex + Len(match.Value)).Text = cnArr(indexOf(enArr, punc))
    Next
    re.Pattern = "[a-zA-Z]([" & Join(cnArr, "") & "])"
    Set Matches = re.Execute(ActiveDocument.Range.Text)
    For Each match In Matches
        punc = match.Submatches.Item(0)
        ActiveDocument.Range(match.FirstIndex + 1, match.FirstIndex + Len(match.Value)).Text = enArr(indexOf(cnArr, punc))
    Next
    
End Sub

Function indexOf(arr, char)
    For i = 0 To UBound(arr)
        If arr(i) = char Then
            indexOf = i
            Exit Function
        End If
    Next
    indexOf = -1
End Function

anytoo

wingh 发表于 2022-4-15 23:31
[mw_shl_code=vb,true]Sub ReplacePunction()
    Set re = CreateObject("VBScript.RegExp")
    enArr  ...

测试，中文段落有英文符号的话，运行不会改为中文符号 比如：  张三,.李四

anytoo

anytoo 发表于 2022-4-16 10:02
测试，中文段落有英文符号的话，运行不会改为中文符号 比如：  张三,.李四

一起运行可能比较复杂，或者能不能单独分开2个帮写下
1 中文段落
讲中文段落中的英文标点改中文；

2英文段落
将英文段落中文符号改英文；

注：
不能全文档运行；只定自己选定的内容进行操作

anytoo

wingh 发表于 2022-4-15 23:31
[mw_shl_code=vb,true]Sub ReplacePunction()
    Set re = CreateObject("VBScript.RegExp")
    enArr  ...

一起运行可能比较复杂，或者能不能单独分开2个帮写下
1.将选定的内容中：中文标点符号改英文；
2.将选定的内容中：英文标点符号改中文；
注：不能全文操作，只对选定的内容操作

wingh

[Visual Basic] 纯文本查看 复制代码

' 程序入口
Sub 全文替换()
    For Each sentence In ActiveDocument.Sentences
        If isEnglishSentence(sentence) Then
            替换标点为英文 sentence
        Else
            替换标点为中文 sentence
        End If
    Next
End Sub
Sub 替换标点为英文(sentence)
    Set re = CreateObject("VBScript.RegExp")
    enArr = Array("-", ".", ",", ";", ":", "?", "!", "…", "~", "(", ")", "<", ">")
    cnArr = Array("—", "。", "，", "；", "：", "？", "！", "……", "～", "（", "）", "《", "》")
    re.Global = True
    re.Pattern = "[" & Join(cnArr, "") & "]"
    Set matches = re.Execute(sentence.Text)
    For Each match In matches
        ActiveDocument.Range(sentence.start + match.FirstIndex, sentence.start + match.FirstIndex + Len(match.Value)).Text = enArr(indexOf(cnArr, match.Value))
    Next
End Sub
Sub 替换标点为中文(sentence)
    Set re = CreateObject("VBScript.RegExp")
    enArr = Array("-", ".", ",", ";", ":", "?", "!", "…", "~", "(", ")", "<", ">")
    cnArr = Array("—", "。", "，", "；", "：", "？", "！", "……", "～", "（", "）", "《", "》")
    re.Global = True
    re.Pattern = "[-\\.,;:\\?!…~\\(\\)<>]"
    Set matches = re.Execute(sentence.Text)
    For Each match In matches
        ActiveDocument.Range(sentence.start + match.FirstIndex, sentence.start + match.FirstIndex + Len(match.Value)).Text = cnArr(indexOf(enArr, match.Value))
    Next
End Sub

Function isEnglishSentence(sentence As Variant)
    Set re = CreateObject("VBScript.RegExp")
    re.Global = True
    re.Pattern = "[\u4e00-\u9fa5]"
    Set matches = re.Execute(sentence.Text)
    If matches.Count > 0 Then
        isEnglishSentence = False
    Else
        isEnglishSentence = True
    End If
End Function

Function indexOf(arr, char)
    For i = 0 To UBound(arr)
        If arr(i) = char Then
            indexOf = i
            Exit Function
        End If
    Next
    indexOf = -1
End Function

anytoo

wingh 发表于 2022-4-16 17:08
[mw_shl_code=vb,true]' 程序入口
Sub 全文替换()
    For Each sentence In ActiveDocument.Sentences

测试会报错，在word2019版本宏中运行。辛苦你了，也可以不用改了

wingh

我发的第一版其实已经能用了，你发的情况多个标点一起的出现的情况是比较少见的。第二版的话，考虑会更加完善，句子中包含中文的话，就当是中文句子来修正，否则就是当英文句子处理，如果句子中同时存在中英文的话，第一版的程序判断会准确一些。