VBA使outlook和Word带谷歌翻译功能

 

 

 

VBA代码如下：

By wgscd

Date:2008/12/26

Blog:http://blog.youkuaiyun.com/wgsnet

1. Macro1()
2.    Dim transString As String
3.    Dim baseUrl As String
4.    Dim para As String
5.    Dim content As String
6.    baseUrl = "http://translate.google.com/translate_a/t?client=t&text="
7.    para = "&sl=en&tl=zh-CN"
8.   If Trim(Selection.Text) = "" Then
9.       Exit Sub
10.    End If
11.    
12.    content = URLEncode(Trim(Selection.Text))
13.    content = Replace(content, "%D", "%0D%0A")
14.    content = Replace(content, "%A1%B1", "%22")
15.    content = Replace(content, "%A1%B0", "%22")
16.    transString = GetHttpPage(baseUrl & content & para)
17.    transString = Replace(transString, "/r/n", vbNewLine)
18.    
19.    MsgBox transString
21. End Sub
25. Function GetHttpPage(HttpUrl)
26.    If IsNull(HttpUrl) = True Or HttpUrl = "$False$" Then
27.       GetHttpPage = "$False$"
28.       Exit Function
29.    End If
30.    Dim http
31.    Set http = CreateObject("MicroSoft.XMLHTTP")
32.    http.Open "GET", HttpUrl, False
33.    http.Send
34.   
35.    If http.ReadyState <> 4 Then
37.       Set http = Nothing
38.       GetHttpPage = "$False$"
39.       Exit Function
40.    End If
41.    
42.     If http.Status = 404 Then '找不到页面
43.     
44.          'MsgBox "404"
45.            GetHttpPage = "$False$"
46.         Exit Function
47.      End If
48.      
49.     
50.    GetHttpPage = BytesToBstr(http.responseBody, "utf-8")
52.    Set http = Nothing
53.    If Err.Number <> 0 Then
54.       Err.Clear
55.    End If
56.    
57.    
58. End Function
60. Function BytesToBstr(Body, Cset)
61.    Dim Objstream
62.    Set Objstream = CreateObject("adodb.stream")
63.    Objstream.Type = 1
64.    Objstream.Mode = 3
65.    Objstream.Open
66.    Objstream.Write Body
67.    Objstream.Position = 0
68.    Objstream.Type = 2
69.    Objstream.Charset = Cset
70.    BytesToBstr = Objstream.ReadText
71.    Objstream.Close
72.    Set Objstream = Nothing
73. End Function
75. Function GetBody(ConStr, StartStr, OverStr, IncluL, IncluR)
76.    If ConStr = "$False$" Or ConStr = "" Or IsNull(ConStr) = True Or StartStr = "" Or IsNull(StartStr) = True Or 
78. OverStr = "" Or IsNull(OverStr) = True Then
79.       GetBody = "$False$"
80.       Exit Function
81.    End If
82.    Dim ConStrTemp
83.    Dim Start, Over
84.    ConStrTemp = LCase(ConStr)
85.    StartStr = LCase(StartStr)
86.    OverStr = LCase(OverStr)
87.    Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)
88.    If Start <= 0 Then
89.       GetBody = "$False$"
90.       Exit Function
91.    Else
92.       If IncluL = False Then
93.          Start = Start + LenB(StartStr)
94.       End If
95.    End If
96.    Over = InStrB(Start, ConStrTemp, OverStr, vbBinaryCompare)
97.    If Over <= 0 Or Over <= Start Then
98.       GetBody = "$False$"
99.       Exit Function
100.    Else
101.       If IncluR = True Then
102.          Over = Over + LenB(OverStr)
103.       End If
104.    End If
105.    GetBody = MidB(ConStr, Start, Over - Start)
106. End Function
108. Function ShowErr(ErrMsg)
109. response.Write "<script>alert('" & ErrMsg & "');history.back();</script>"
110. response.End
112. End Function
116. ''--------url编码函数-----------------
118.  Public Function URLEncode(ByRef strURL As String) As String
119.   Dim I     As Long
120.   Dim tempStr     As String
121.   For I = 1 To Len(strURL)
122.           If Asc(Mid(strURL, I, 1)) < 0 Then
123.                 tempStr = "%" & Right(CStr(Hex(Asc(Mid(strURL, I, 1)))), 2)
124.                 tempStr = "%" & Left(CStr(Hex(Asc(Mid(strURL, I, 1)))), Len(CStr(Hex(Asc(Mid(strURL, I, 1))))) - 2) & 
126. tempStr
127.                 URLEncode = URLEncode & tempStr
128.           ElseIf (Asc(Mid(strURL, I, 1)) >= 65 And Asc(Mid(strURL, I, 1)) <= 90) Or (Asc(Mid(strURL, I, 1)) >= 97 And 
130. Asc(Mid(strURL, I, 1)) <= 122) Then
131.                 URLEncode = URLEncode & Mid(strURL, I, 1)
132.           Else
133.                 URLEncode = URLEncode & "%" & Hex(Asc(Mid(strURL, I, 1)))
134.           End If
135.   Next
136.   End Function
137.     
139. ''---------URL反编码函数-------------------
140.   Public Function URLDecode(ByRef strURL As String) As String
141.   Dim I     As Long
142.     
143.   If InStr(strURL, "%") = 0 Then URLDecode = strURL:                   Exit Function
144.     
145.   For I = 1 To Len(strURL)
146.           If Mid(strURL, I, 1) = "%" Then
147.                 If Val("&H" & Mid(strURL, I + 1, 2)) > 127 Then
148.                       URLDecode = URLDecode & Chr(Val("&H" & Mid(strURL, I + 1, 2) & Mid(strURL, I + 4, 2)))
149.                       I = I + 5
150.                 Else
151.                       URLDecode = URLDecode & Chr(Val("&H" & Mid(strURL, I + 1, 2)))
152.                       I = I + 2
153.                 End If
154.           Else
155.                 URLDecode = URLDecode & Mid(strURL, I, 1)
156.           End If
157.   Next
158.   End Function

   

然后是自定义工具栏和自定义按钮，将宏关联到按钮上，不会自定义的自己google下,^_^…………。

 

当然改动参数 para = "&sl=en&tl=zh-CN" 可设置其他语言之间翻译。

 

希望对大家有用。