LIL_JAN
Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
Здравствуйте подскажите пожалуйста. Можно ли создать макрос или надстройку для перевода текста с одного языка на дугой в excel?
Нашел на просторах интернета два макроса. Вот только один не переводит как только нажимаю транслит тот надписи исчезают. А второй как я понял больше не работает из за изменений в получении апи ключа у гоогла.
Function Translate$(ByVal TextToBeTranslated$, ByVal resultLanguageCode$, _
Optional ByVal sourceLanguageCode$ = "")
' переводит текст TextToBeTranslated$ с языка sourceLanguageCode$
' на язык resultLanguageCode$, используя сервис переводов Google Translate
Application.Volatile True
Set ADOStream = CreateObject("ADODB.Stream")
With ADOStream
.Charset = "utf-8": .Mode = 3: .Type = 2: .Open
.WriteText TextToBeTranslated: .Flush: .Position = 0
.Type = 1: .Read 3: ByteArrayToEncode = .Read(): .Close
End With
For i = 0 To UBound(ByteArrayToEncode)
iAsc = ByteArrayToEncode(i)
Select Case iAsc ' переводим текст в кодировку, понятную Google
Case 32: sTemp$ = "+" 'space
Case 48 To 57, 65 To 90, 97 To 122: sTemp$ = Chr(ByteArrayToEncode(i))
Case Else: sTemp$ = "%" & Hex(iAsc) 'Chr(iAsc)
End Select
txt$ = txt$ & sTemp$
Next
' формируем ссылку, по которой Google выдаст нам файл с переводом
URL$ = "http://translate.google.com.ua/translate_a/t?client=json&text=" & _
txt$ & "&hl=" & resultLanguageCode$ & "&sl=" & sourceLanguageCode$
Set XMLHTTP = CreateObject("Microsoft.XMLHTTP") ' скачиваем файл
XMLHTTP.Open "GET", Replace(URL$, "\", "/"), "False": XMLHTTP.send
If XMLHTTP.statustext = "OK" Then
LocalPath$ = Environ("TMP") & "\google.txt"
With ADOStream ' перекодировка файла
.Type = 1: .Open: .Write XMLHTTP.responseBody
.SaveToFile LocalPath$, 2
.Close: .Type = 2: .Charset = "utf-8": .Open:
.LoadFromFile LocalPath$ ' загружаем данные из файла
Translate$ = .ReadText ' считываем текст файла в переменную Translate$
End With
On Error Resume Next ' вырезаем нужный текст из ответа
Translate$ = Split(Translate$, """trans"":""")(1)
Translate$ = Split(Translate$, """,""orig")(0)
Translate$ = Replace(Translate$, "quot;", Chr(39))
If Translate$ = " null, " Then Translate$ = "Не переведено"
End If
Set XMLHTTP = Nothing: Set ADOStream = Nothing
End Function
Sub Translate()
Dim cell1 as Range, cell2 As Range
Dim i as Long, Langs As Long
Langs = 3 'количество языков перевода, включая русский
For Each cell1 In ActiveSheet.Cells.SpecialCells(xlCellTypeConstants)
For Each cell2 In Worksheets("Словарь").Cells.SpecialCells(xlCellTypeConstants)
If cell1.Value = cell2.Value Then
i = cell2.Column
If i = Langs Then i = 1 Else i = i + 1
cell1.Value = Worksheets("Словарь").Cells(cell2.Row, i).Value
GoTo 1
End If
Next cell2
1: Next cell1
End Sub
|
Всего записей: 230 | Зарегистр. 18-03-2009 | Отправлено: 19:21 02-06-2015 | Исправлено: LIL_JAN, 22:20 02-06-2015 |
|
