如何通过VBA删除括号内光标所在中文词（组）外的内容?

tangqingfu

请教如何通过VBA代码,删除括号内光标所在中文词（组）外的内容?
文档中单词有多个中文意思,各中文意思可能是以分号或逗号进行分隔,现在只要保留右击光标所在的中文意思,其他中文意思做删除处理(但仍保留中文意思的括号)(希望在右击时，能在右键中选择如“选取”时，就能删除括号内其他的中文意思及光标处所有中文意思中除括号外的所有西文字符)；如果光标处的中文意思前后还含有西文字符或中文标点,也一并将其删除。但类似这样该中文意思中如果含有中、西文括号的，则不做处理
如：(词（组）)或（词(组)）保持原样（即不做处理）
原文档
One of the qualities that most people admire (vt.钦佩；羡慕；赞美)in others is the willingness to admit (vt.允许进入；v.承认，供认；准许…进入，准许…加入)one’s mistakes .It is extremely (ad.极度地；ad.极端地，非常地)hard sometimes to say a simple thing like “I was wrong about that,” and it is even harder to say,“ I was wrong, and you were right about that.”
现文档
One of the qualities that most people admire (钦佩)in others is the willingness to admit (承认)one’s mistakes .It is extremely (非常地)hard sometimes to say a simple thing like “I was wrong about that,” and it is even harder to say,“ I was wrong, and you were right about that.”

[ 本帖最后由 tangqingfu 于 2009-7-30 10:41 编辑 ]

wjhere

正好这几天在思考这个问题。
Sub test()
'需要要删除的东西都在括号内，且括号中没有其他括号
'光标选定解释，或者处在所选的解释词语中间。
'可见对于光标处于插入状态的时候所取的结果很不理想，
'像 vt.允许进入，向……学习这类解释中包含多个词语
Dim strSel As String
With Selection
    If .Type = wdSelectionIP Then
    strSel = .Words(1).Text
    Else
    strSel = .Text
    End If
          .MoveEndUntil Cset:="(", Count:=wdBackward
          .MoveEndUntil Cset:=")", Count:=wdForward
          .Text = strSel
End With
End Sub

sylun

也可试试如下代码的适应性：
Sub test()
Dim i As Integer, Lngstart As Long, Lngend As Long, myRange As Range
With Selection
    If .Type <> wdSelectionIP Then Exit Sub
    Do
        i = i + 1
    Loop Until .Previous(wdCharacter, i) Like "(" And .Previous(wdCharacter, i + 1) Like "[A-Za-z ]"
    Lngstart = .Previous(wdCharacter, i).End
    i = 0
    Do
        i = i + 1
    Loop Until .Next(wdCharacter, i) Like ")" And .Next(wdCharacter, i + 1) Like "[A-Za-z ]"
    Lngend = .Next(wdCharacter, i).Start
    Set myRange = ActiveDocument.Range(Lngstart, Lngend)
    Do While .Previous Like "[一-龥(（）)… ]" And .Start > Lngstart
        .Start = .Start - 1
    Loop
    Do While .Next Like "[一-龥(（）)… ]" And .Start < Lngend
        .End = .End + 1
    Loop
    myRange.Text = .Text
End With
End Sub

至于右键菜单，楼主可通过“自定义”设置

wjhere

sylun兄的代码加上On Error Resume Next可以正常运行。对光标处于插入状态时候可以很好取得类似 跟…一样 的短语。这种字符循环的办法让我看了眼界。也发现一些小问题：
1、vt.喜欢 这样的解释如何包含前面的词性说明
2、有时候右边半个括号丢失。

tangqingfu

长见识了,PF!PF!
能否请wjhere兄和sylun兄加入代码注释,让我等学习?

[ 本帖最后由 tangqingfu 于 2009-7-31 09:40 编辑 ]

tangqingfu

To sylun兄:
不小心在其他处运行代码,会弹出"对象变量或With块变量未设置",能否解决这一问题,即即使误运行,也不弹出这一对话框?

[ 本帖最后由 tangqingfu 于 2009-7-31 09:47 编辑 ]

sylun

上述代码是有点问题，主要是复制条件代码段时个别地方没有作相应改动，并且没有考虑插入点置于括号内容最后的情形。
请再试试如下代码，只是要注意，即使插入点在括号内，其前后也不能都为英数字符（如在词性缩写字符串中间）：
Sub test()
Dim i As Integer, Lngstart As Long, Lngend As Long, myRange As Range
With Selection
    If .Type <> wdSelectionIP Then Exit Sub
    Do
        i = i + 1
    Loop Until .Previous(wdCharacter, i) Like "(" And .Previous(wdCharacter, i + 1) Like "[A-Za-z ]"
    Lngstart = .Previous(wdCharacter, i).End
    If .Text Like ")" And .Next Like "[A-Za-z ]" Then
        Lngend = .End
    Else
        i = 0
        Do
            i = i + 1
        Loop Until .Next(wdCharacter, i) Like ")" And .Next(wdCharacter, i + 1) Like "[A-Za-z ]"
        Lngend = .Next(wdCharacter, i).Start
    End If
    Set myRange = ActiveDocument.Range(Lngstart, Lngend)
    Do While .Previous Like "[一-龥(（）)… ]" And .Start > Lngstart
        .Start = .Start - 1
    Loop
    Do While .Next Like "[一-龥(（）)… ]" And .End < Lngend
        .End = .End + 1
    Loop
    myRange.Text = .Text
End With
End Sub

wjhere

sylun兄的代码仍然有运行错误提示。
我的注释一下：
Sub test()
Dim strSel As String
With Selection
    If .Type = wdSelectionIP Then '当光标为插入状态时取光标当前单词
    strSel = .Words(1).Text
    Else
    strSel = .Text '否则取光标选定部分文本
    End If
    '分别向左向右扩展选定部分直到遇到括号，然后替换选定部分字符。
          .MoveEndUntil Cset:="(", Count:=wdBackward
          .MoveEndUntil Cset:=")", Count:=wdForward
          .Text = strSel
End With
End Sub

tangqingfu

改进以后,运行效果更理想了!谢谢sylun兄!
代码对这样的内容处理不是太好：
Mr(n.先生(Mister的缩写)), spoke(n.幅条，轮辐；vt.说，讲(语言)(speak的过去式))
,能否将(Mister的缩写)、(speak的过去式)全部删除或全部保留？
不小心在其他处（无括号处的内容）运行代码,会弹出"对象变量或With块变量未设置",能否解决这一问题,即即使误运行,也不弹出这一对话框?

sylun

实在是复杂！改用另一种处理方法，请再测试。
Sub test()
Dim TF As Boolean, myRange As Range
With Selection
    If .Type <> wdSelectionIP Then Exit Sub
    Set myRange = .Paragraphs(1).Range
    With myRange.Find  '确定每一对括号（如果有）的内容范围
        .ClearFormatting
        .Text = "\(*\)"
        .MatchWildcards = True
        Do While .Execute
            Do While UBound(Split(.Parent, "(")) <> UBound(Split(.Parent, ")"))  '处理嵌套括号内容
                .Parent.MoveEndUntil ")"
                .Parent.End = .Parent.End + 1
            Loop
            If Selection.InRange(.Parent) Then  '如果插入点在该对括号内容范围内
                TF = True
                myRange.SetRange myRange.Start + 1, myRange.End - 1  '确定所指目标内容范围
                Exit Do
            End If
            .Parent.Collapse wdCollapseEnd
        Loop
        If TF = False Then Exit Sub
    End With
   
    Do While .Previous Like "[!，；]" And .Start > myRange.Start  '确定所需保留内容的起始位置
        .Start = .Start - 1
    Loop
    Do While .Next Like "[!，；]" And .End < myRange.End  '确定所需保留内容的结束位置
        .End = .End + 1
    Loop
    myRange.Text = .Text
    '试图删除词性缩写词（存在误删可能）
    If InStr(Left(myRange, InStr(myRange, ".")), "[一-龥]") = 0 _
        Then myRange.Text = Mid(myRange, InStr(myRange, ".") + 1)
End With
End Sub