Private Const strSHORTCODES As String = ",en,af,sq,ar,hy,az,eu,be,bn,bg,ca,zh,hr,cs,da,nl,eo,et,tl,fi,fr,gl,ka,de,el,gu,ht,iw,hi,hu,is,id,ga,it,ja,kn,ko,lo,la,lv,lt,mk,ms,mt,no,fa,pl,pt-PT,ro,ru,sr,sk,sl,es,sw,sv,ta,te,th,tr,uk,ur,vi,cy,yi"
Public Enum eLanguage
Auto_Detect = 0: English = 1: Afrikaans = 2: Albanian = 3: Arabic = 4: Armenian = 5: Azerbaijani = 6: Basque = 7: Belarusian = 8: Bengali = 9: Bulgarian = 10: Catalan = 11: Chinese = 12: Croatian = 13: Czech = 14: Danish = 15: Dutch = 16: Esperanto = 17: Estonian = 18: Filipino = 19: Finnish = 20: French = 21: Galician = 22: Georgian = 23: German = 24: Greek = 25: Gujarati = 26: Haitian_Creole = 27: Hebrew = 28: Hindi = 29: Hungarian = 30: Icelandic = 31: Indonesian = 32: Irish = 33: Italian = 34: Japanese = 35: Kannada = 36: Korean = 37: Lao = 38: Latin = 39: Latvian = 40: Lithuanian = 41: Macedonian = 42: Malay = 43: Maltese = 44: Norwegian = 45: Persian = 46: Polish = 47: Portuguese = 48: Romanian = 49: Russian = 50: Serbian = 51: Slovak = 52: Slovenian = 53: Spanish = 54: Swahili = 55: Swedish = 56: Tamil = 57: Telugu = 58: Thai = 59: Turkish = 60: Ukrainian = 61: Urdu = 62: Vietnamese = 63: Welsh = 64: Yiddish = 65:
End Enum
Public Sub Test1()
Dim wksForeign As Excel.Worksheet
Dim wksResults As Excel.Worksheet
Dim rngCell As Excel.Range
Set wksForeign = Worksheets(1)
For Each rngCell In Selection 'wksForeign.Range("A1:A20")
rngCell.Offset(0, 1).Value2 = Translate(rngCell.Value2, English, Arabic)
Next rngCell
End Sub
Public Sub Test2()
Dim wksForeign As Excel.Worksheet
Dim wksResults As Excel.Worksheet
Dim rngCell As Excel.Range
Set wksForeign = Worksheets(1)
For Each rngCell In Selection 'wksForeign.Range("A1:A20")
rngCell.Offset(0, 1).Value2 = Translate(rngCell.Value2, Arabic, English)
Next rngCell
End Sub
Public Function Translate(ByVal strText As String, _
Optional ByVal eFrom As String, _
Optional ByVal eTo As String) As String
Dim strUrl As String
Dim strResult As String
strUrl = "https://translate.googleapis.com/translate_a/single?client=gtx&sl={F}&tl={T}&dt=t&q={S}"
strUrl = Replace$(strUrl, "{S}", UTF8_Encode(strText))
strUrl = Replace$(strUrl, "{F}", Split(strSHORTCODES, ",")(eFrom))
strUrl = Replace$(strUrl, "{T}", Split(strSHORTCODES, ",")(eTo))
With CreateObject("MSXML2.XMLHTTP")
Call .Open("get", strUrl, False)
Call .Send
strResult = .responseText
End With
varSplitText = Split(Split(strResult, "]],")(0), "[")
If Not blnPhonetic Then
For lngItem = 3 To UBound(varSplitText)
strTransText = strTransText & Split(varSplitText(lngItem), ",")(0)
Next
Else
For lngItem = 3 To UBound(varSplitText)
strTransText = strTransText & Split(varSplitText(lngItem), "delimitChar")(2)
Next
End If
strResult = Replace(strTransText, """", "")
Translate = strResult
End Function
Public Function UTF8_Encode(ByVal strIn As String) As String
'Returns a URI string representing the Hexadecimal UTF-8 representation of strIn.
'Modified from code on this page: http://www.nonhostile.com/howto-convert-byte-array-utf8-string-vb6.asp
'Now handles Unicode surrogate pairs.
'
'There's a bit of an issue with how to handle control characters (code points < &H20). As the code
'is currently written line feeds (LF) and tabs are stripped and carriage returns (CR) are replaced
'with spaces. This works well for the Speak function. Leaving in the CRs causes them to be returned,
'as XML. The XML then gets spoken. This is not ideal for the Translate function. Stripping the CRs
'obviously hurts the original formating. This is just a demo, so I've left this unresolved.
'4/17/2013 Greg Zjaba
Dim lngPos As Long
Dim lngUSV As Long
Dim strUTF8 As String
strIn = Trim(strIn)
For lngPos = 1 To Len(strIn)
lngUSV = MakeUSV(Mid$(strIn, lngPos, 2))
If lngUSV < &H10 And lngUSV <> &HA And lngUSV <> &H9 Then
'Single digit code points. Need to add 0 after %.
'IMPORTANT NOTE: Also stripping LF and Tab
If lngUSV <> &HD Then 'CR
strUTF8 = strUTF8 & "%0" & Hex(AscW(Mid$(strIn, lngPos, 1)))
Else
strUTF8 = strUTF8 & "%20" 'Replace CR with space.
End If
ElseIf lngUSV > &H1F And lngUSV < &H80 Then
'US-ASCII - Basic Latin
strUTF8 = strUTF8 & "%" & Hex(AscW(Mid$(strIn, lngPos, 1)))
ElseIf lngUSV > &H7F And lngUSV < &H800 Then
'Basic Multilingual Plane
strUTF8 = strUTF8 & "%" & Hex((lngUSV \ &H40) Or &HC0)
strUTF8 = strUTF8 & "%" & Hex((lngUSV And &H3F) Or &H80)
ElseIf lngUSV > &H7FF And lngUSV < &H10000 Then
'Basic Multilingual Plane
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H1000) And &HF) Or &HE0)
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H40) And &H3F) Or &H80)
strUTF8 = strUTF8 & "%" & Hex((lngUSV And &H3F) Or &H80)
ElseIf lngUSV > &HFFFF& And lngUSV < &H2A700 Then
'Surrogate pairs - Supplementary Multilingual Plane.
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H40000) And &H7) Or &HF0)
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H1000&) And &H3F) Or &H80)
strUTF8 = strUTF8 & "%" & Hex(((lngUSV \ &H40) And &H3F) Or &H80)
strUTF8 = strUTF8 & "%" & Hex((lngUSV And &H3F) Or &H80)
End If
If IsHighSurrogate(AscW(Mid$(strIn, lngPos, 1))) Then
lngPos = lngPos + 1
End If
Next
UTF8_Encode = strUTF8
End Function
Public Function MakeUSV(strCharacter As String) As Long
' Makes Unicode USV value for one character.
' USV is returned as a decimal value and as a Long.
' Handles surrogate pairs.
' 4/17/2013 GZ
Dim lngHiSurr As Long 'Value of high surrogate.
Dim lngLowSurr As Long 'Value of low surrogate.
'Testing for length of 1 or 2 character. If a single character is represented
'by a surrogate pair Len() will report it's length as 2.
If LenB(strCharacter & vbNullString) <> 0 And Len(strCharacter) <= 2 Then
If IsSurrogatePair(strCharacter) Then
lngLowSurr = CLng("&H" & Hex$(AscW(Mid$(strCharacter, 2, 1))))
lngHiSurr = CLng("&H" & Hex$(AscW(Left$(strCharacter, 1))))
'From "The Unicode Standard, Version 6.0", Chapter 3, Section 7 "Surrogates".
MakeUSV = (lngHiSurr - CLng("&HD800")) * CLng("&H400") + _
(lngLowSurr - CLng("&HDC00")) + CLng("&H10000")
Else
MakeUSV = CLng("&H" & Hex$(AscW(strCharacter)))
End If
End If
End Function
Private Function IsSurrogatePair(txtCharacter As String) As Boolean
' Tests if a character is represented by a Unicode surrogate pair.
' Takes a single Unicode character as argument and returnes true or false.
' 4/17/2013 GZ
Dim lngHiSurr As Long
' NOTE: Len returns 2 for a single character if it is a surrogate pair.
If LenB(txtCharacter & vbNullString) <> 0 And Len(txtCharacter) <= 2 Then
lngHiSurr = CLng("&H" & Hex$(AscW(Mid$(txtCharacter, 1, 1))))
If Len(txtCharacter) = 2 Then
If lngHiSurr >= &HD800& And lngHiSurr <= &HDBFF& Then
IsSurrogatePair = True
Else
IsSurrogatePair = False
End If
Else
IsSurrogatePair = False
End If
End If
End Function
Public Function IsHighSurrogate(intCodePoint As Integer) As Boolean
'Returns true if code point is a Unicode high surrogate.
'4/17/2013 GZ
Const cintHighSurrLB As Integer = &HD800 'Lower bound
Const cintHighSurrUB As Integer = &HDBFF 'Upper bound
If intCodePoint >= cintHighSurrLB And intCodePoint <= cintHighSurrUB Then
IsHighSurrogate = True
Else
IsHighSurrogate = False
End If
End Function
