Замена названий городов - VB
Формулировка задачи:
Нужно написать код программы которая в документе заменит названия городов, например москва,челябинск из записью по английски. Подсчитать число замен и вывести в окно сообщений MsgBox. Для запуска программы вынести на панель инструментов кнопку.
Решение задачи: «Замена названий городов»
textual
Листинг программы
'---------------------------------------------------------------------------------------
' Модуль : modFunctions
' Автор : EducatedFool (Игорь) Дата: 29.03.2011
' Разработка макросов для Excel, Word, CorelDRAW. Быстро, профессионально, недорого.
' [url]http://excelvba.ru/[/url] ICQ: 5836318 Skype: ExcelVBA.ru
' Реквизиты для оплаты: [url]http://excelvba.ru/payments[/url]
'---------------------------------------------------------------------------------------
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 TranslateRuToEn()
Dim Src$
Src = "Москва"
Debug.Print Translate(Src, "en", "ru")
End Sub