✔ Programação GLOBAL®: PIECE OF CAKE - VBA Excel - Traduzindo Planilhas - MS Excel VBA Script to Translate worksheets using the Google Translate API

Consultancy in Excel, Access, VBA & PowerPoint projects

DESENVOLVO APLICAÇÕES

Perguntas, Questões e Esclarecimentos

Existem códigos de Perl para traduzir planilhas MS Excel usando o Google Translate ao passo que preserva a formatação. Diga-se de passagem, essa maneira é demorada, não confiável, complicada, etc. Acredito que esta seja solução melhor.

Coloque o código abaixo em sua planilha MS Excel habilitada para processar código VBA em sua pasta de trabalho pessoal e crie um atalho para isso (use Ctrl + shift + t). Este código usará o Google Translate API. Ele traduzirá todas as células não-vazias e não numéricas na planilha ativa, colocando a tradução em uma nova planilha, mantendo a formatação original. Colocará o valor original das células numéricas (não traduzidas) na nova planilha.

A nova planilha terá o mesmo nome da planilha original, com o código de duas letras do idioma selecionado nela. Se uma planilha com esse nome já existir, será excluída.

Ao executar o código, precisará especificar alguns parâmetros em uma caixa de diálogo que aparecerá:
1. Sua chave da API do Google. A API de tradução do Google não é gratuita, custa uns US$ 20 por cada 1MB de caracteres
2. Código da língua de duas letras do idioma origem
3. Código da língua de duas letras do idioma destino

(Nos intens 2 e 3, precisará usar os códigos de idioma que a API de tradução do Google suporta. Consulte-os aqui)

Sub TranslateWorsheet()

' A função original está codificação aqui.
' Antes de executar este script, adicione a versão mais atualizada do
' Microsoft Script Control como
' referência (Ferramentas -> Referências no Editor VB)

' Passo 1: Crie uma nova planilha: worksheetname_2lettertargetlanguagecode
' Passo 2: Na folha atual, faça um looping em todas as células não vazias
' A) envie o pedido REST para a API para traduzir o conteúdo da célula se não for
' numérico, de outra forma, cole o conteúdo original da célula.
' B) colocar o conteúdo traduzido na célula correspondente da nova planilha.
' C) copiar também a formatação da célula.

Dim destinationWorksheetName As String
Dim sourceWorksheetName As String
Dim cellContent As String
Dim cellAddress As String
Dim sourceWorksheet As Worksheet
Dim destinationWorksheet As Worksheet

Dim ScriptEngine As ScriptControl
Set ScriptEngine = New ScriptControl
Let ScriptEngine.Language = "JScript"
ScriptEngine.AddCode "function encode(str) {return encodeURIComponent(str);}"

' use regualr expression to get the translation
Dim RE As Object
Set RE = CreateObject("VBScript.RegExp")
  Let RE.Pattern = "\[\s*{\s*""translatedText"": ""(.*)""\s}*"
  Let RE.IgnoreCase = False
  Let RE.Global = False
  Let RE.MultiLine = True
Dim testResult As Boolean

' send the translation request
Dim REMatches As Object
Dim translateD As String
Dim sourceString As String
Dim K As String
Dim URL As String
Dim encodedSourceString As String
Dim sourceLanguage As String
Dim destinationLanguage As String
Set sourceWorksheet = ActiveSheet
  Let sourceWorksheetName = ActiveSheet.Name

' sourceString = "Hello World"
  Let destinationLanguage = "EN"
  Let sourceLanguage = "PT"
  Let K = InputBox(prompt:="Please enter your Google Translate API key", Title:="Google Translate API Key Required: For more info, see https://developers.google.com/translate/v2/getting_started")

'obTranslateOptions.Show
'sourceLanguage = obTranslateOptions.obSourceLanguage.Text
'destinationLanguage = obTranslateOptions.obDestinationLanguage.Text
'K = obTranslateOptions.obKey.Text

'Debug.Print "K=" & K
'Debug.Print "sourceLanguage=" & sourceLanguage
'Debug.Print "destinationLanguage=" & destinationLanguage

' Unload obTranslateOptions

' If a worksheet of this name in this workbook already exist, then delete it
  Let destinationWorksheetName = sourceWorksheetName & "_" & destinationLanguage
  Let Application.DisplayAlerts = False
On Error Resume Next
Sheets(destinationWorksheetName).Delete
  Let Application.DisplayAlerts = True
On Error GoTo 0

' Prepare to send the request
Dim objHTTP As Variant
Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
Dim responseT As String

' copy active worksheet, clear contents of the copy
ActiveWorkbook.ActiveSheet.Copy after:=ActiveWorkbook.ActiveSheet
  Let ActiveSheet.Name = destinationWorksheetName
ActiveSheet.Cells.ClearContents
Set destinationWorksheet = ActiveSheet

sourceWorksheet.Activate
' loop through all non-empty cells or all selected cells
Dim cell As Range
For Each cell In ActiveSheet.UsedRange.Cells

'Debug.Print cell.Address
  Let cellAddress = cell.Address
  Let sourceString = cell.Value
'Debug.Print "sourceString:" & sourceString

' do only for non-numeric cells
If (IsNumeric(cell.Value) = False) Then

' encode the source text
  Let encodedSourceString = ScriptEngine.Run("encode", sourceString)
' prepare and send the request
  Let URL = "https://www.googleapis.com/language/translate/v2?key=" & K & "&source=" & sourceLanguage & "&target=" & destinationLanguage & "&q=" & encodedSourceString
objHTTP.Open "GET", URL, False
objHTTP.SetRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
objHTTP.send ("")
responseT = objHTTP.ResponseText
' Debug.Print "responseT:" & responseT

' pull the translation from the response to the request
If (RE.Test(responseT) = True) Then
'Debug.Print "re.test is true"
Set REMatches = RE.Execute(responseT)
  Let translateD = REMatches.Item(0).SubMatches.Item(0)
'Debug.Print "translateD:" & translateD
Else
'Debug.Print "re.test is false"
End If

destinationWorksheet.Range(cellAddress).Value = translateD
Else
destinationWorksheet.Range(cellAddress).Value = cell.Value
End If
Next


End Sub

#A&A #API #Google #GoogleTranslate #GoogleTranslateAPI #GoogleTranslator #MSEXCEL #Perl #PIECEOFCAKE #script #translate #POC #VBA

Defina a Latitude e a Longitude - Find Latitude and Longitude of any address using Google Map API and VBA