两个label控件
两个Textbox控件
一个按钮控件
两个Combox控件
两个Option
一个用于朗读的Windows Media Player控件 名称=Voice
text1名称=SourceContent
text2名称=ResultContent
在添加个模块：GetPostByXmlHttp
下面我们在Form1输入代码！
我们来测试一下
OK，已经可以了，由于时间关系，窗体布局就大家自己去弄得更好看的，像我现在在使用的一样，也蛮漂亮的
给大家，看一下
晕 ，还得做个续集  呵呵。
怎么样还可以吧？
好了，高手不要见笑啊
我的：QQ：1302938783
QQ：26891547
希望大家多多给我宝贵意见
谢谢观看  bye
Dim NationalCode$()'定义变量
Private Sub Command1_Click()
If SourceContent.Text = "" Then Exit Sub
Dim SourceURL$, PostData$, ReturnCode$
If Option1 Then
SourceURL = "udao/translate"
PostData = "i=" & UnicodeToUtf8(SourceContent.Text) & "&type=AUTO&action=%E7%BF%BB%E8%AF%91&ue=UTF-8&keyfrom=fanyi.web&smartresult=dict&smartresult=rule"
ReturnCode = Replace(Replace(RemoveHeadTail(PostXmlHttp(SourceURL, PostData), "name=""o"">", "</textarea>"), " ", vbCrLf), ",", "")
If ReturnCode <> "" Then Voice.URL = "udao/fanyivoice?word=" & Replace(ReturnCode, " ", "%20")
Else
If Len(SourceContent.Text) < 220 Then
SourceURL = "le/translate_a/t?client=t&text=" & _
UnicodeToUtf8(SourceContent.Text) & "&hl=zh-CN&sl=" & NationalCode(Combo1.ListIndex) & _
"&tl=" & NationalCode(Combo2.ListIndex) & "&pc=0&prev=btn"
ReturnCode = RemoveChr(GetXmlHttp(SourceURL), "GET")
If Combo2.ListIndex <> 56 And ResultContent.Text <> "" And Len(SourceContent.Text) < 34 Then
Voice.URL = "le/translate_tts?q=" & Replace(ReturnCode, " ", "%20") & "&tl=en"
End If
Else
SourceURL = "le/"
PostData = "js=y&prev=_t&hl=zh-CN&ie=UTF-8&layout=1&eotf=1&text=" & UnicodeToUtf8(SourceContent.Text) & _
"&file=&sl=" & NationalCode(Combo1.ListIndex) & "&tl=" & NationalCode(Combo2.ListIndex)
ReturnCode = RemoveChr(RemoveHeadTail(PostXmlHttp(SourceURL, PostData), "name=gtrans value=""", """><div id=sug_exp>"), "POST")
End If
End If
ResultContent.Text = ReturnCode
End Sub
Private Sub Form_Load()
ResultContent.Text = ""
Dim National$(), Tem$
Dim i&
Tem = "中文 英语"
National = Split(Tem)
Tem = "zh-CN en sq ar az ga et be bg is pl fa af da de ru fr tl fi ka ht ko nl gl ca cs hr lv lt ro mt ms mk no pt ja sv sr sk sl " & _
"sw th tr cy uk eu es iw el hu hy it yi hi ur id vi"
NationalCode = Split(Tem)
For i = LBound(National) To UBound(National)
Combo1.AddItem
National(i)
Combo2.AddItem National(i)
Next i
Combo1.ListIndex = 0
Combo2.ListIndex = 1
SourceContent.Text = "编程论坛"
Option1.Value = True '默认“有道”翻译
End Sub
模块：GetPostByXmlHttp
Option Explicit
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
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 Const CP_UTF8 = 65001
Function GetXmlHttp(ByVal GetUrl As String) As String
Dim XmlHttp As Object
Set XmlHttp = CreateObject("MSXML2.XMLHTTP")
XmlHttp.Open "GET", GetUrl, True
XmlHttp.send
Do adystate = 4
DoEvents
Loop
GetXmlHttp = XmlHttp.ResponseText
Set XmlHttp = Nothing
End Function
Function PostXmlHttp(ByVal PostUrl As String, ByVal PostData As String) As String
Dim XmlHttp As Object
Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
With XmlHttp
.Open "POST", PostUrl, True
.SetRequestHeader "Accept", "image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/x-shockwave-flash, application/vnd.ms-excel, application/vnd.ms-powerpoint, application/msword, application/x-silverlight, */*"
.SetRequestHeader "Referer", PostUrl
.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
.SetRequestHeader "Accept-Encoding", "gzip, deflate"
.SetRequestHeader "Content-Length", Len(PostData)
.SetRequestHeader "Connection", "Keep-Alive"
.SetRequestHeader "Cache-Control", "no-cache"
.send (PostData)
Do Until .readystate = 4
DoEvents
Loop
PostXmlHttp = .ResponseText
End With
Set XmlHttp = Nothing
End Function
Function UnicodeToUtf8(ByVal sData As String) As String
Dim aRetn() As Byte, nSize As Long, ReturnStr As String, X As Long
Dim lLength As Long
Dim lBufferSize As Long
Dim lResult As Long
Dim abUTF8() As Byte
lLength = Len(sData)
If lLength = 0 Then Exit Function
lBufferSize = lLength * 3 + 1
ReDim aRetn(lBufferSize - 1)
nSize = WideCharToMultiByte(CP_UTF8, 0, StrPtr(sData), lLength, aRetn(0), lBufferSize, vbNullString, 0)
If nSize = 0 Then Exit Function
ReDim Preserve aRetn(0 To nSize - 1) As Byte
For X = LBound(aRetn) To UBound(aRetn)
unicode在线工具
ReturnStr = ReturnStr & "%" & String(2 - Len(Hex(aRetn(X))), "0") & Hex(aRetn(X))
Next X
Erase aRetn
UnicodeToUtf8 = ReturnStr
End Function
Function RemoveHeadTail(ByVal Source As Variant, ByVal sStart As String, ByVal st
rEnd As String) As String
On Error Resume Next
Dim m As Long
Dim n As Long
RemoveHeadTail = ""
m = InStr(1, Source, sStart)
If m <> 0 Then
n = InStr(m + Len(sStart) + 1, Source, strEnd)
If n <> 0 Then
RemoveHeadTail = Mid(Source, m + Len(sStart), n - m - Len(sStart))
Else
Exit Function
End If
Else
Exit Function
End If
End Function
Function RemoveChr(ByVal Source As String, ByVal UsrType As String) As String
If UsrType = "GET" Then
If InStr(Source, "]]]") <> 0 Then
Source = RemoveHeadTail(Source, "]],[[", "]]]")
Else
If Form1.Combo2.ListIndex = 1 Then
Source = RemoveHeadTail(Source, "[[[""", """,") & "."
Else
Source = RemoveHeadTail(Source, "[[[""", """,")
End If
End If
Source = Replace(Source, "]],", vbCrLf)
Source = Replace(Source, ",[", ":")
Source = Replace(Source, "[", "")
Source = Replace(Source, """", "")
Else
Do Until InStr(Source, "&quot;") = 0
Source = Replace(Source, "&quot;", Chr(34))
Loop
Source = Replace(Source, "<", "")
Source = Replace(Source, "br>", "")
End If
RemoveChr = Source
End Function

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。