这几天发了不少有关Excel VBA实现翻译功能的技巧，但是实现这个功能的大侠根本停不下来，又出升级版了，决定要将Excel翻译进行到底。今天就来一个鼠标取词即时翻译
这个功能以前是金山词霸的招牌功能，今天就用Excel来实现它，当然，是在Excel单元格里鼠标取词，不过，已经非常好用了。不信，就进来瞧瞧
作者：Office中国-江苏大侠
实现的 鼠标取词即时翻译 功能界面：
即时翻译操作动画：
实现的Excel VBA核心源码：
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As MyPoint) As Long 'by江苏大侠 QQ:22752944
Private Type MyPoint: X As Long: Y As Long: End Type
Public flag
Public myRng As Range
Public yy
Public dyy
Public 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
loopsub
End Sub
Public Sub setlang()
UserForm2.Show (0)
End Sub
Public Sub endscan()
flag = False
ActiveSheet.Shapes("翻译").Visible = False
End Sub
Sub loopsub()
If flag = True Then
mousetarget
Application.OnTime Now + TimeValue("00:00:01"), "loopsub"
End If
DoEvents
End Sub
Sub 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 If
End 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