Google Excel 的翻译功能不工作
Google Translate function for Excel not working
我有这个功能可以翻译所有选定的单元格 Google 翻译。
多年来我工作得很好,但由于某种原因突然停止工作。
知道为什么吗?我正在使用 Excel 2010.
提前致谢
Sub TranslateCell()
Dim getParam As String, trans As String, translateFrom As String, translateTo As String
translateFrom = "en"
translateTo = "fr"
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
Dim r As Range, cell As Range
Set cell = Selection
For Each cell In Selection.Cells
getParam = ConvertToGet(cell.Value)
URL = "https://translate.google.fr/m?hl=" & translateFrom & "&sl=" & translateFrom & "&tl=" & translateTo & "&ie=UTF-8&prev=_m&q=" & getParam
objHTTP.Open "GET", URL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send ("")
If InStr(objHTTP.responseText, "div dir=""ltr""") > 0 Then
trans = RegexExecute(objHTTP.responseText, "div[^""]*?""ltr"".*?>(.+?)</div>")
cell.Value = Clean(trans)
Else
MsgBox ("Error")
End If
Next cell
End Sub
'----Used functions----
Function ConvertToGet(val As String)
val = Replace(val, " ", "+")
val = Replace(val, vbNewLine, "+")
val = Replace(val, "(", "%28")
val = Replace(val, ")", "%29")
ConvertToGet = val
End Function
Function Clean(val As String)
val = Replace(val, """, """")
val = Replace(val, "%2C", ",")
val = Replace(val, "'", "'")
Clean = val
End Function
Public Function RegexExecute(str As String, reg As String, _
Optional matchIndex As Long, _
Optional subMatchIndex As Long) As String
On Error GoTo ErrHandl
Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = reg
regex.Global = Not (matchIndex = 0 And subMatchIndex = 0) 'For efficiency
If regex.Test(str) Then
Set matches = regex.Execute(str)
RegexExecute = matches(matchIndex).SubMatches(subMatchIndex)
Exit Function
End If
ErrHandl:
RegexExecute = CVErr(xlErrValue)
End Function
我的猜测是 Google 已经更改了响应 HTML 并且您的代码正在寻找 t运行slation 的 DIV 不再是其中的一部分响应格式。
我 运行 并得到了一个有效的响应页面。我更改了您的代码以使用此“新”响应。
试试这个:
Sub TranslateCell()
Dim objHTTP As Object, URL$
Dim getParam As String, trans As String, translateFrom As String, translateTo As String
translateFrom = "en"
translateTo = "fr"
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
Dim r As Range, cell As Range
Set cell = Selection
For Each cell In Selection.Cells
getParam = ConvertToGet(cell.Value)
URL = "https://translate.google.fr/m?hl=" & translateFrom & "&sl=" & translateFrom & "&tl=" & translateTo & "&ie=UTF-8&prev=_m&q=" & getParam
objHTTP.Open "GET", URL, False
objHTTP.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.Send
'If InStr(objHTTP.responseText, "div dir=""ltr""") > 0 Then
If InStr(objHTTP.responseText, "<div class=""result-container"">") Then
'trans = RegexExecute(objHTTP.responseText, "div[^""]*?""ltr"".*?>(.+?)</div>")
trans = RegexExecute(objHTTP.responseText, "div[^""]*?""result-container"".*?>(.+?)<\/div>")
cell.Value = Clean(trans)
Else
MsgBox "Error"
End If
Next cell
End Sub
我有这个功能可以翻译所有选定的单元格 Google 翻译。
多年来我工作得很好,但由于某种原因突然停止工作。
知道为什么吗?我正在使用 Excel 2010.
提前致谢
Sub TranslateCell()
Dim getParam As String, trans As String, translateFrom As String, translateTo As String
translateFrom = "en"
translateTo = "fr"
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
Dim r As Range, cell As Range
Set cell = Selection
For Each cell In Selection.Cells
getParam = ConvertToGet(cell.Value)
URL = "https://translate.google.fr/m?hl=" & translateFrom & "&sl=" & translateFrom & "&tl=" & translateTo & "&ie=UTF-8&prev=_m&q=" & getParam
objHTTP.Open "GET", URL, False
objHTTP.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send ("")
If InStr(objHTTP.responseText, "div dir=""ltr""") > 0 Then
trans = RegexExecute(objHTTP.responseText, "div[^""]*?""ltr"".*?>(.+?)</div>")
cell.Value = Clean(trans)
Else
MsgBox ("Error")
End If
Next cell
End Sub
'----Used functions----
Function ConvertToGet(val As String)
val = Replace(val, " ", "+")
val = Replace(val, vbNewLine, "+")
val = Replace(val, "(", "%28")
val = Replace(val, ")", "%29")
ConvertToGet = val
End Function
Function Clean(val As String)
val = Replace(val, """, """")
val = Replace(val, "%2C", ",")
val = Replace(val, "'", "'")
Clean = val
End Function
Public Function RegexExecute(str As String, reg As String, _
Optional matchIndex As Long, _
Optional subMatchIndex As Long) As String
On Error GoTo ErrHandl
Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = reg
regex.Global = Not (matchIndex = 0 And subMatchIndex = 0) 'For efficiency
If regex.Test(str) Then
Set matches = regex.Execute(str)
RegexExecute = matches(matchIndex).SubMatches(subMatchIndex)
Exit Function
End If
ErrHandl:
RegexExecute = CVErr(xlErrValue)
End Function
我的猜测是 Google 已经更改了响应 HTML 并且您的代码正在寻找 t运行slation 的 DIV 不再是其中的一部分响应格式。
我 运行 并得到了一个有效的响应页面。我更改了您的代码以使用此“新”响应。
试试这个:
Sub TranslateCell()
Dim objHTTP As Object, URL$
Dim getParam As String, trans As String, translateFrom As String, translateTo As String
translateFrom = "en"
translateTo = "fr"
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
Dim r As Range, cell As Range
Set cell = Selection
For Each cell In Selection.Cells
getParam = ConvertToGet(cell.Value)
URL = "https://translate.google.fr/m?hl=" & translateFrom & "&sl=" & translateFrom & "&tl=" & translateTo & "&ie=UTF-8&prev=_m&q=" & getParam
objHTTP.Open "GET", URL, False
objHTTP.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.Send
'If InStr(objHTTP.responseText, "div dir=""ltr""") > 0 Then
If InStr(objHTTP.responseText, "<div class=""result-container"">") Then
'trans = RegexExecute(objHTTP.responseText, "div[^""]*?""ltr"".*?>(.+?)</div>")
trans = RegexExecute(objHTTP.responseText, "div[^""]*?""result-container"".*?>(.+?)<\/div>")
cell.Value = Clean(trans)
Else
MsgBox "Error"
End If
Next cell
End Sub