|
|
发表于 2020-11-29 06:22
来自手机
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
谢谢分享，代码贴出，方便手机查看。
#if win64这段有点复杂。。。
=有道翻译.xlsm=============
Attribute VB_Name = "GETMD5"
Public Function CreateObjectx86(Optional sProgID, Optional bClose = False)
Static oWnd As Object
Dim bRunning As Boolean
#If Win64 Then
bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
If bClose Then
If bRunning Then oWnd.Close
Exit Function
End If
If Not bRunning Then
Set oWnd = CreateWindow()
oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
End If
Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
#Else
Set CreateObjectx86 = CreateObject("MSScriptControl.ScriptControl")
#End If
End Function
Public Function CreateWindow()
Dim sSignature, oShellWnd, oProc
On Error Resume Next
sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
Do
For Each oShellWnd In CreateObject("Shell.Application").Windows
Set CreateWindow = oShellWnd.GetProperty(sSignature)
If Err.Number = 0 Then Exit Function
Err.Clear
Next
Loop
End Function
Public Function MD5(s)
Dim js, res
Set mx = CreateObject("Msxml2.XMLHTTP.6.0")
mx.Open "GET", "http://www.cmd5.com/md5.js", False
mx.send
Set js = CreateObjectx86("msscriptcontrol.scriptcontrol")
js.Language = "JavaScript"
js.AddCode mx.responsetext
res = js.CodeObject.hex_md5(s)
CreateObjectx86 , True
MD5 = res
End Function
Attribute VB_Name = "fanyi"
Option Explicit
Dim objWin As Object, objDom As Object
#If VBA7 And Win64 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Sub Fy_YD()
Dim Url$, Postdata$, Cookie$, User_Agent$, i&, xmlhttp, arr, res
Set objDom = CreateObject("htmlfile"): Set objWin = objDom.parentWindow: Set xmlhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
User_Agent = "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/87.0.4280.66 Safari/537.36"
With xmlhttp
Url = "http://fanyi.youdao.com"
.Open "GET", Url, False
.setRequestHeader "User-Agent", User_Agent
.send
Cookie = .GetResponseHeader("set-cookie")
End With
arr = Range("a1:a" & Cells(Rows.Count, 1).End(3).Row)
ReDim res(1 To UBound(arr), 0 To 1)
With xmlhttp
Url = "http://fanyi.youdao.com/translate_o?smartresult=dict&smartresult=rule"
.Open "POST", Url, False
.setRequestHeader "User-Agent", User_Agent
.setRequestHeader "Referer", "http://fanyi.youdao.com/"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
For i = 2 To UBound(arr)
Postdata = Post_Data(arr(i, 1))
.send (Postdata)
Sleep 888
If InStr(.responsetext, "errorCode"":0") > 0 Then
Cells(i, 2) = Split(Split(.responsetext, "translateResult"":[""")(1), """],""errorCode")(0)
End If
If InStr(.responsetext, "entries"":[") > 0 Then
Cells(i, 3) = Replace(Split(Split(.responsetext, "entries"":[""")(1), """],""type")(0), "\r\n", " ")
End If
Next
End With
End Sub
Function Post_Data(word)
objWin.execScript "var s =encodeURI('" & word & "')"
Post_Data = "i=" & objWin.s & "&client=fanyideskweb&keyfrom=fanyi.web&salt=1&sign=" & MD5("fanyideskweb" & word & "1]BjuETDhU)zqSxf-=B#7m")
End Function
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
