使用 VBA（Excel 宏）将文本框内容从西班牙语翻译和替换为英语

Question

我希望尽可能高效地翻译 Excel 工作簿文件，其中包含单元格中的某些内容和放置在每个工作表中的文本框对象中的其他内容。我发现了一些创建 VBA 宏来翻译单元格中文本的很好的示例，但这些示例不适用于文本框中的文本。

如果有人能够弄清楚如何运行下面的 TranslateCell 宏以及如何在工作簿中的所有工作表中运行新的文本框翻译宏，那就太棒了。其中一些文件多达 70 个工作表，因此必须手动选择每个工作表上的单元格/对象进行翻译仍然非常耗时。

我使用“David Iracheta”在他的帖子中的示例创建了下面的宏，用于翻译单元格中的文本，并根据“Foxfire And Burns Burns”使用 VBA 的 Google 翻译 -（Excel 宏）问题进行了调整。很确定我至少需要更改“设置单元格=选择”以及整个宏中对单元格的大多数其他引用，以制作一个对文本框对象中的文本执行相同操作的版本，但我缺乏经验，无法弄清楚我自己的。

Sub TranslateCell()
'English Spanish Translator Using Google Translate
    Dim getParam As String, trans As String, translateFrom As String, translateTo As String
'In translateFrom we will select the language from which we will translate E.g. "es" = Spanish
    translateFrom = "es"
'In translateTo we select the language that we want to translate to. "en" = English
    translateTo = "en"
    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.pl/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
            cell.Value = Clean(CStr(Split(Split(objHTTP.responsetext, "<div class=""result-container"">")(1), "</div>")(0)))
            'MsgBox ("Error")
        End If
    Next cell
End Sub
 
'----Functions Used----
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, "&quot;", """")
    val = Replace(val, "%2C", ",")
    val = Replace(val, "&#39;", "'")
    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 greater 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

Answer 1

您需要稍微分解一下代码，使“翻译”成为一个仅翻译传递给它的文本的函数。

示例：

Option Explicit

Const FROM_LANG As String = "es"
Const TO_LANG As String = "en"


Sub Tester()

    TranslateTextShape ActiveSheet.Shapes(1)
    
    TranslateRange ActiveSheet.Range("D13:D15")

End Sub

'loop each cell in `rng` and translate if needed
Sub TranslateRange(rng As Range)
    Dim c As Range, v
    For Each c In rng.Cells
        v = c.Value
        If TranslateThis(v) Then
            c.Value = Translate(v)
        End If
    Next c
End Sub

'Translate text in a shape
Sub TranslateTextShape(shp As Shape)
    Dim v
    With shp.TextFrame2.TextRange
        v = .Text
        If TranslateThis(v) Then .Text = Translate(v)
    End With
End Sub


'----Functions Used----
Function Translate(ByVal txt As String) As String
'English Spanish Translator Using Google Translate
    Dim getParam As String, trans As String, objHTTP As Object, url As String
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    getParam = Application.EncodeURL(txt) '#######
    url = "https://translate.google.pl/m?hl=" & FROM_LANG & "&sl=" & FROM_LANG & _
          "&tl=" & TO_LANG & "&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>")
        Translate = Clean(trans)
    Else
        Translate = Clean(CStr(Split(Split(objHTTP.responseText, "<div class=""result-container"">")(1), "</div>")(0)))
    End If
End Function
 
'does this look like something to translate?
Function TranslateThis(v) As Boolean
    If Not IsError(v) Then
        If Len(v) > 0 Then
            If Not IsNumeric(v) Then
                v = Trim(v)
                TranslateThis = Len(v) > 0
            End If
        End If
    End If
End Function

Function Clean(val As String)
    val = Replace(val, "&quot;", """")
    val = Replace(val, "%2C", ",")
    val = Replace(val, "&#39;", "'")
    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 greater 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 Translate API 而不是使用此解决方法可能是值得的。这不是很昂贵 - 例如参见 https://cloud.google.com/translate/pricing#basic-pricing