为VB应用程序添加英汉翻译功能

      原来写了一个利用IE浏览器通过google进行英汉翻译的代码，后来才发现在某些机器上后由于对话框阻塞而不能运行，因此，在SupermanKing的代码启发下，干脆也改用XMLHTTP进行数据提交，并完全利用了SupermanKing的两个函数，因此，此程序可以说得上是转载，贴在此处供朋友们学习。

      代码如下：

'* ************************************************************** * '* 程序名称：frmTranslate '* 程序功能：利用GOOGLE实现英汉翻译 '* 作者：lyserver '* 联系方式：http://blog.youkuaiyun.com/lyserver '* ************************************************************** * Option Explicit '====================================================================== ' API 声明 '====================================================================== Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long Private Const CP_ACP = 0 ' default to ANSI code page Private Const CP_UTF8 = 65001 ' default to UTF-8 code page '====================================================================== ' 函数名称：EncodeToBytes ' 函数说明：SupermanKing编制的基于UTF-8的BASE64编码函数 '====================================================================== Public Function EncodeToBytes(ByVal sData As String) As String Dim aRetn() As Byte, nSize As Long, ReturnStr As String, X As Long nSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sData), -1, 0, 0, 0, 0) - 1 If nSize = 0 Then Exit Function ReDim aRetn(0 To nSize - 1) As Byte WideCharToMultiByte CP_UTF8, 0, StrPtr(sData), -1, VarPtr(aRetn(0)), nSize, 0, 0 For X = LBound(aRetn) To UBound(aRetn) ReturnStr = ReturnStr & "%" & String(2 - Len(Hex(aRetn(X))), "0") & Hex(aRetn(X)) Next X Erase aRetn EncodeToBytes = ReturnStr End Function '====================================================================== ' 函数名称：Utf8ToUnicode ' 函数说明：SupermanKing编制的UTF-8编码和Unicode编码的转换函数 '====================================================================== Function Utf8ToUnicode(ByRef Utf() As Byte) As String Dim lRet As Long Dim lLength As Long Dim lBufferSize As Long lLength = UBound(Utf) - LBound(Utf) + 1 If lLength <= 0 Then Exit Function lBufferSize = lLength * 2 Utf8ToUnicode = String$(lBufferSize, Chr(0)) lRet = MultiByteToWideChar(CP_UTF8, 0, VarPtr(Utf(0)), lLength, StrPtr(Utf8ToUnicode), lBufferSize) If lRet <> 0 Then Utf8ToUnicode = Left(Utf8ToUnicode, lRet) End If End Function '====================================================================== ' 函数名称：btnTranslate_Click ' 函数说明：进行英汉翻译 '====================================================================== Private Sub btnTranslate_Click() Dim XHttp As New XMLHTTP Dim bytBuffer() As Byte Dim strSource As String, strResult As String Dim strSign_1 As String, strSign_2 As String '对消息体进行URL编码 strSource = "hl=zh-CN&ie=UTF-8&text=" & EncodeToBytes(txtSource) '确定编译方式 strSource = strSource & IIf(Options(0), "&sl=en&tl=zh-CN", "&sl=zh-CN&tl=en") '以同步方式发送HTTP消息包 XHttp.open "POST", "http://translate.google.cn/translate_t", False XHttp.setRequestHeader "Referer", "http://translate.google.cn/translate_t" XHttp.setRequestHeader "Accept-Charset", "gb2312,utf-8;q=0.7,*;q=0.7" XHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded" XHttp.setRequestHeader "Content-Length", Len(strSource) XHttp.send strSource '读取XMLHTTP返回结果并转换为UNICODE bytBuffer = XHttp.responseBody strResult = Utf8ToUnicode(bytBuffer) '过滤掉结果前后的字符串 strSign_1 = "<div id=result_box dir=" & Chr(34) & "ltr" & Chr(34) & ">" strSign_2 = "<" strResult = Mid(strResult, InStr(strResult, strSign_1) + Len(strSign_1)) strResult = Left(strResult, InStr(strResult, strSign_2) - 1) '显示结果 txtResult = strResult '释放资源 Erase bytBuffer Set XHttp = Nothing End Sub