• 自动标注音标升级版


    Option Explicit
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
     
    '为选择的文本中的每个单词注上音标
    Sub Start()
        On Error Resume Next
        
        '文档
        Dim Document As Document
        Set Document = ActiveDocument
         
        '各个索引
        Dim currentIndex As Long, endIndex As Long
        currentIndex = Selection.Start
        endIndex = Selection.End
         
        '正则表达式,用于搜索单词
        Dim regex As Object
        Set regex = CreateObject("VBScript.RegExp")
        With regex
            .MultiLine = True
            .IgnoreCase = True
            .Pattern = "[a-z]+" '限制纯英文
        End With
         
        '开始工作
        Do While currentIndex < endIndex
            '获取余后要比较的文本
            Dim rng As Range, text As String
            Set rng = Document.Range(currentIndex, endIndex)
            text = rng.text
             
            '匹配结果
            Dim matches As Object
            Set matches = regex.Execute(text)
            If matches.count > 0 Then
                Dim match As Object
                Set match = matches(0)
                 
                '新单词
                Dim word As String, wordStart As Long, wordEnd As Long
                word = match.Value
                wordStart = currentIndex + match.FirstIndex
                wordEnd = wordStart + match.Length
                 
                '查询
                Dim explanation As String
                If (Not Lookup(word, explanation)) Then
                    Exit Do
                End If
                 
                '插入
                Dim wordRng As Range
                Set wordRng = Document.Range(wordStart, wordEnd)
                wordRng.InsertAfter explanation
                 
                '设置样式
                Dim explanationRng As Range
                Set explanationRng = Document.Range(wordEnd, wordRng.End)
                explanationRng.Font.Color = RGB(0, 0, 0)
                explanationRng.HighlightColorIndex = wdGray25
                explanationRng.Font.Size = "8"
                '设置音标字体
                Dim innerRng As Range
                Set innerRng = Document.Range(wordEnd + 1, wordRng.End - 1)
                innerRng.Font.Name = "Kingsoft Phonetic Plain"
                 
                '准备下一次
                currentIndex = wordRng.End
                endIndex = endIndex + Len(explanation)
            Else
                Exit Do
            End If
        Loop
    End Sub
     
    Function Lookup(word As String, ByRef explanation As String) As Boolean
        Lookup = True
     
        '确保有翻译软件
        Dim translator As String
        translator = "金山词霸2007(暂停取词)"
        If Tasks.Exists(translator) = False Then'查询词典软件是否在运行中(要以管理员身份运行此VBA)
            MsgBox "请打开金山词霸2007并将其最小化至任务栏中"
            Lookup = False
            Exit Function    '如果未在任务栏中则关闭程序
        End If
     
        '查询单词
        Tasks(translator).WindowState = wdWindowStateNormal    '正常窗口
        Tasks(translator).Activate    '激活金山词霸应用程序,此处填写金山词霸任务栏的内容,如金山词霸2007
        SendKeys word, True    '发送单词
        'Sleep 1000
        SendKeys "{TAB 2}", True    '移动二次TAB
        'Sleep 500
        SendKeys "^a", True    '复制
        'Sleep 500
        SendKeys "^c", True    '复制
        Sleep 800   '稍微停顿一下以等待以前的操作完成
     
        '获取查询结果
        Dim MyData As MSForms.DataObject
        Set MyData = New MSForms.DataObject    '引用DataObject(随便拖一个窗体控件进来便可以引入其DLL)
        MyData.GetFromClipboard    '从剪贴板复制数据到 DataObject
     
        Dim CopyTxt As String
        CopyTxt = MyData.GetText(1)    '获得无格式文本
          
        Dim Mystring() As String
        Mystring = VBA.Split(CopyTxt, vbCrLf)    '返回一个数组
     
        explanation = Mystring(1)    '取得数组中的第二个值,也就是音标
     
        '最小化翻译软件
        Tasks(translator).WindowState = wdWindowStateMinimize
        
        '成功
        Lookup = True
    End Function
    
    

      

  • 相关阅读:
    7月30日 举办专注于微服务的.NET Conf Focus
    我和ABP vNext 的故事
    Windows环境搞好的Dockerfile文件 在Linux上报错了
    [LeetCode] 955. Delete Columns to Make Sorted II 删除列使其有序之二
    [LeetCode] 954. Array of Doubled Pairs 两倍数对儿数组
    上周热点回顾(8.3-8.9)团队
    发布新版首页“外婆新家”升级版:全新的UI,熟悉的味道团队
    上周热点回顾(7.27-8.2)团队
    终于换新颜:新版网站首页发布上线团队
    上周热点回顾(7.20-7.26)团队
  • 原文地址:https://www.cnblogs.com/beta2013/p/3518859.html
Copyright © 2020-2023  润新知