将Excel翻译进行到底-鼠标取词即时翻译

这几天发了不少有关Excel VBA实现翻译功能的技巧，但是实现这个功能的大侠根本停不下来，又出升级版了，决定要将Excel翻译进行到底。今天就来一个鼠标取词即时翻译这个功能以前是金山词霸的招牌功能，今天就用Excel来实现它，当然，是在Excel单元格里鼠标取词，不过，已经非常好用了。不信，就进来瞧瞧
作者：Office中国-江苏大侠
实现的鼠标取词即时翻译功能界面：

1480427334611653.jpg

即时翻译操作动画：

1480427378132692.gif

实现的Excel VBA核心源码：Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As MyPoint) As Long  'by江苏大侠 QQ:22752944Private Type MyPoint: X As Long: Y As Long: End TypePublic flagPublic myRng As RangePublic yyPublic dyyPublic Sub startscan()  Set dyy = CreateObject("Scripting.Dictionary")  If yy = "" Then yy = "英语"  dyy("英语") = "en"  dyy("德语") = "de"  dyy("法语") = "fr"  dyy("中文") = "zh-CN"  dyy("俄语") = "ru"  dyy("韩语") = "ko"  dyy("日语") = "ja"  dyy("阿尔巴尼亚语") = "sq"  dyy("阿拉伯语") = "ar"  dyy("阿塞拜疆语") = "az"  dyy("爱尔兰语") = "ga"  dyy("爱沙尼亚语") = "et"  dyy("巴斯克语") = "eu"  dyy("白俄罗斯语") = "be"  dyy("保加利亚语") = "bg"  dyy("冰岛语") = "is"  dyy("波兰语") = "pl"  dyy("波斯尼亚语") = "bs"  dyy("波斯语") = "fa"  dyy("布尔语(南非荷兰语)") = "af"  dyy("丹麦语") = "da"  dyy("菲律宾语") = "tl"  dyy("芬兰语") = "fi"  dyy("高棉语") = "km"  dyy("格鲁吉亚语") = "ka"  dyy("古吉拉特语") = "gu"  dyy("哈萨克语") = "kk"  dyy("海地克里奥尔语") = "ht"  dyy("豪萨语") = "ha"  dyy("荷兰语") = "nl"  dyy("加利西亚语") = "gl"  dyy("加泰罗尼亚语") = "ca"  dyy("捷克语") = "cs"  dyy("卡纳达语") = "kn"  dyy("克罗地亚语") = "hr"  dyy("拉丁语") = "la"  dyy("拉脱维亚语") = "lv"  dyy("老挝语") = "lo"  dyy("立陶宛语") = "lt"  dyy("罗马尼亚语") = "ro"  dyy("马尔加什语") = "mg"  dyy("马耳他语") = "mt"  dyy("马拉地语") = "mr"  dyy("马拉雅拉姆语") = "ml"  dyy("马来语") = "ms"  dyy("马其顿语") = "mk"  dyy("毛利语") = "mi"  dyy("蒙古语") = "mn"  dyy("孟加拉语") = "bn"  dyy("缅甸语") = "my"  dyy("苗语") = "hmn"  dyy("南非祖鲁语") = "zu"  dyy("尼泊尔语") = "ne"  dyy("挪威语") = "no"  dyy("旁遮普语") = "pa"  dyy("葡萄牙语") = "pt"  dyy("齐切瓦语") = "ny"  dyy("瑞典语") = "sv"  dyy("塞尔维亚语") = "sr"  dyy("塞索托语") = "st"  dyy("僧伽罗语") = "si"  dyy("世界语") = "eo"  dyy("斯洛伐克语") = "sk"  dyy("斯洛文尼亚语") = "sl"  dyy("斯瓦希里语") = "sw"  dyy("宿务语") = "ceb"  dyy("索马里语") = "so"  dyy("塔吉克语") = "tg"  dyy("泰卢固语") = "te"  dyy("泰米尔语") = "ta"  dyy("泰语") = "th"  dyy("土耳其语") = "tr"  dyy("威尔士语") = "cy"  dyy("乌尔都语") = "ur"  dyy("乌克兰语") = "uk"  dyy("乌兹别克语") = "uz"  dyy("希伯来语") = "iw"  dyy("希腊语") = "el"  dyy("西班牙语") = "es"  dyy("匈牙利语") = "hu"  dyy("亚美尼亚语") = "hy"  dyy("伊博语") = "ig"  dyy("意大利语") = "it"  dyy("意第绪语") = "yi"  dyy("印地语") = "hi"  dyy("印尼巽他语") = "su"  dyy("印尼语") = "id"  dyy("印尼爪哇语") = "jw"  dyy("约鲁巴语") = "yo"  dyy("越南语") = "vi"  flag = True  loopsubEnd SubPublic Sub setlang()  UserForm2.Show (0)End SubPublic Sub endscan()  flag = False  ActiveSheet.Shapes("翻译").Visible = FalseEnd SubSub loopsub()  If flag = True Then    mousetarget    Application.OnTime Now + TimeValue("00:00:01"), "loopsub"  End If  DoEventsEnd SubSub mousetarget()  Dim x1, y1, m  Dim sword, intxt, fy, jg  Dim CurRng  Dim CurPos As MyPoint  GetCursorPos CurPos  x1 = CurPos.X: y1 = CurPos.Y  Set CurRng = ActiveWindow.RangeFromPoint(x1, y1)  If CurRng Is Nothing Then Exit Sub  On Error Resume Next  If TypeName(CurRng) = "Range" Then    If myRng.Address  CurRng.Address Then    If CurRng  "" Then      Set myRng = CurRng      ActiveSheet.Shapes("翻译").TextEffect.Text = fanyi(CurRng, dyy(yy))      ActiveSheet.Shapes("翻译").Visible = True      ActiveSheet.Shapes("翻译").Left = CurRng.Left + CurRng.Width      ActiveSheet.Shapes("翻译").Top = CurRng.Top    Else      ActiveSheet.Shapes("翻译").Visible = False    End If    End If  End IfEnd Sub
Public Function fanyi(rng, lang)  Dim tlang  URL = "http://api.microsofttranslator.com/V2/Ajax.svc/Translate?oncomplete=&appId=" _  & "708BEDCB01828123DC7B6C6A6AB12EF82DFBB611&from=&to=" & lang & "&text=" & rng  Set oH = CreateObject("WinHttp.WinHttpRequest.5.1")  oH.Open "get", URL, False  oH.Send  fanyi = Mid(oH.ResponseText, 3, Len(oH.ResponseText) - 3)End Function