VBA decode URI data

It’s not only img block that accepts Data URIs, in HTML5 audio and video also accept it as a source, as well as standard file URLs.
URI information has this form:

data:[<MIME-type>][;charset=<encoding>][;base64],<data>

Would be interesting to hide -hindering download- some graphical elements as binary text, thus needed to encode/decode. So rearranging code from here got a functional tool for this task.

Option Explicit

Private Const clOneMask As Long = 16515072          '000000 111111 111111 111111
Private Const clTwoMask As Long = 258048             '111111 000000 111111 111111
Private Const clThreeMask As Long = 4032             '111111 111111 000000 111111
Private Const clFourMask As Long = 63               '111111 111111 111111 000000

Private Const clHighMask As Long = 16711680         '11111111 00000000 00000000
Private Const clMidMask As Long = 65280             '00000000 11111111 00000000
Private Const clLowMask As Long = 255               '00000000 00000000 11111111

Private Const cl2Exp18 As Long = 262144             '2 to the 18th power
Private Const cl2Exp12 As Long = 4096               '2 to the 12th
Private Const cl2Exp6 As Long = 64                  '2 to the 6th
Private Const cl2Exp8 As Long = 256                 '2 to the 8th
Private Const cl2Exp16 As Long = 65536              '2 to the 16th

Public Sub sFileEncode64()
    Dim iFileIn As Integer
    Dim strFullPathFile As String
    Dim sBinary As String

    iFileIn = VBA.FreeFile()
    strFullPathFile = VBA.Environ$("UserProfile") & "\Documents\###." & "png"
    Open strFullPathFile For Binary As #iFileIn
    sBinary = String$(LOF(iFileIn), Chr$(0))
    Get #iFileIn, , sBinary
    Close #iFileIn

    Debug.Print Encode64(sBinary)
End Sub

Public Function sTest_DecodeURI()
    Dim strURI As String
    strURI = _
           "data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAABYAAAAWCAYAAADEtGw7AAAABGdBTUEAALGPC/xhBQAAAAZiS0dEAP8A/wD/oL2nkwAAAAlwSFlzAAALEwAACxMBAJqcGAAAAAd0SU1FB9oEBxcZFmGboiwAAAAIdEVYdENvbW1lbnQA9syWvwAAAuFJREFUOMvtlUtsjFEUx//n3nn0YdpBh1abRpt4LFqtqkc3jRKkNEIsiIRIBBEhJJpKlIVo4m1RRMKKjQiRMJRUqUdKPT71qpIpiRKPaqdF55tv5vvusZjQTjOlseUkd3Xu/3dPzusC/22wtu2wRn+jG5So/OCDh8ycMJDflehMlkJkVK7KUYN+ufzA/RttH76zaVocDptRxzQtNi3mRWuPc+6cKtlXZ/sddP2uu9uXlmYXZ6Qm8v4Tz8lhF1H+zDQXt7S8oLMXtbF4e8QaFHjj3kbP2MzkktHpiTjp9VH6iHiA+whtAsX5brpwueMGdONdf/2A4M7ukDs1JW662+XkqTkeUoqjKtOjm2h53YFL15pSJ04Zc94wdtibr26fXlC2mzRvBccEbz2kiRFD414tKMlEZbVGT33+qCoHgha81SWYsew0r1uzfNylmtpx80pngQQ91LwVk2JGvGnfvZG6YcYRAT16GFtW5kKKfo1EQLtfh5Q2etT0BIWF+aitq4fDbk+ImYo1OxvGF03waFJQvBCkvDffRyEtxQiFFYgAZTHS0zwAGD7fG5TNnYNTp8/FzvGwJOfmgG7GOx0SAKKgQgDMgKBI0NJGMEImpGDk5+WACEwEd0ywblhGUZ4Hw5OdUekRBLT7DTgdEgxACsIznx8zpmWh7k4rkpJcuHDxCul6MDsmmBXDlWCH2+XozSgBnzsNCEE4euYV4pwCpsWYPW0UHDYBKSWu1NYjENDReqtKjwn2+zvtTc1vMSTB/mvev/WEYSlASsLimcOhOBJxw+N3aP/" & _
           "SjefNL5GePZmpu4kG7OPr1+tOfPyUu3BecWYKcwQcDFmwFKAUo90fhKDInBCAmvqnyMgqUEagQwCoHBDc1rjv9pIlD8IbVkz6qYViIBQGTJPx4k0XpIgEZoRN1Da0cij4VfR0ta3WvBXH/rjdCufv6R2zPgPH/e4pxSBCpeatqPrjNiso203/5s/zA171Mv8+w1LOAAAAAElFTkSuQmCC"
    Call Decode64(strURI)
End Function

Public Function Encode64(ByVal sString As String) As String
    Dim bTrans(63) As Byte
    Dim lPowers8(255) As Long
    Dim lPowers16(255) As Long
    Dim bOut() As Byte
    Dim bIn() As Byte
    Dim lChar As Long
    Dim lTrip As Long
    Dim iPad As Integer
    Dim lLen As Long
    Dim lTemp As Long
    Dim lPos As Long
    Dim lOutSize As Long

    For lTemp = 0 To 63                                 'Fill the translation table.
        Select Case lTemp
            Case 0 To 25
                bTrans(lTemp) = 65 + lTemp              'A - Z
            Case 26 To 51
                bTrans(lTemp) = 71 + lTemp              'a - z
            Case 52 To 61
                bTrans(lTemp) = lTemp - 4               '1 - 0
            Case 62
                bTrans(lTemp) = 43                      'Chr(43) = "+"
            Case 63
                bTrans(lTemp) = 47                      'Chr(47) = "/"
        End Select
    Next lTemp

    For lTemp = 0 To 255                                'Fill the 2^8 and 2^16 lookup tables.
        lPowers8(lTemp) = lTemp * cl2Exp8
        lPowers16(lTemp) = lTemp * cl2Exp16
    Next lTemp

    iPad = Len(sString) Mod 3                           'See if the length is divisible by 3
    If iPad Then                                        'If not, figure out the end pad and resize the input.
        iPad = 3 - iPad
        sString = sString & String(iPad, Chr(0))
    End If

    bIn = StrConv(sString, vbFromUnicode)               'Load the input string.
    lLen = ((UBound(bIn) + 1) \ 3) * 4                  'Length of resulting string.
    lTemp = lLen \ 72                                   'Added space for vbCrLfs.
    lOutSize = ((lTemp * 2) + lLen) - 1                 'Calculate the size of the output buffer.
    ReDim bOut(lOutSize)                                'Make the output buffer.

    lLen = 0                                            'Reusing this one, so reset it.

    For lChar = LBound(bIn) To UBound(bIn) Step 3
        lTrip = lPowers16(bIn(lChar)) + lPowers8(bIn(lChar + 1)) + bIn(lChar + 2)    'Combine the 3 bytes
        lTemp = lTrip And clOneMask                     'Mask for the first 6 bits
        bOut(lPos) = bTrans(lTemp \ cl2Exp18)           'Shift it down to the low 6 bits and get the value
        lTemp = lTrip And clTwoMask                     'Mask for the second set.
        bOut(lPos + 1) = bTrans(lTemp \ cl2Exp12)       'Shift it down and translate.
        lTemp = lTrip And clThreeMask                   'Mask for the third set.
        bOut(lPos + 2) = bTrans(lTemp \ cl2Exp6)        'Shift it down and translate.
        bOut(lPos + 3) = bTrans(lTrip And clFourMask)   'Mask for the low set.
        If lLen = 68 Then                               'Ready for a newline
            bOut(lPos + 4) = 13                         'Chr(13) = vbCr
            bOut(lPos + 5) = 10                         'Chr(10) = vbLf
            lLen = 0                                    'Reset the counter
            lPos = lPos + 6
        Else
            lLen = lLen + 4
            lPos = lPos + 4
        End If
    Next lChar

    If bOut(lOutSize) = 10 Then lOutSize = lOutSize - 2 'Shift the padding chars down if it ends with CrLf.

    If iPad = 1 Then                                    'Add the padding chars if any.
        bOut(lOutSize) = 61                             'Chr(61) = "="
    ElseIf iPad = 2 Then
        bOut(lOutSize) = 61
        bOut(lOutSize - 1) = 61
    End If

    Encode64 = StrConv(bOut, vbUnicode)                 'Convert back to a string and return it.

End Function

Public Function Decode64(ByVal sString As String) As Boolean
    Dim lgPosition As Long
    Dim strURI As String
    Dim strMIMEtype As String
    Dim strData As String

    'data:[][;charset=][;base64],
    'data:image/png;base64,
    'data:audio/ogg;base64,
    'data:video/webm;base64,
    'data:video/mp4;base64,

    lgPosition = 1
    lgPosition = VBA.InStr(lgPosition, sString, "/")
    strMIMEtype = VBA.Mid$(sString, lgPosition + 1, VBA.InStr(lgPosition, sString, ";") - lgPosition - 1)
    sString = VBA.Mid$(sString, VBA.InStr(1, sString, ",") + 1)

    Dim bOut() As Byte
    Dim bIn() As Byte
    Dim bTrans(255) As Byte
    Dim lPowers6(63) As Long
    Dim lPowers12(63) As Long
    Dim lPowers18(63) As Long
    Dim lQuad As Long
    Dim iPad As Integer
    Dim lChar As Long
    Dim lPos As Long
    Dim lTemp As Long
    Dim lgRetVal As Long

    sString = Replace(sString, vbCr, vbNullString)      'Get rid of the vbCrLfs.  These could be in...
    sString = Replace(sString, vbLf, vbNullString)      'either order.

    lTemp = Len(sString) Mod 4                          'Test for valid input.
    If lTemp Then
        GoTo ErrControl
        'Call Err.Raise(vbObjectError, "MyDecode", "Input string is not valid Base64.")
    End If

    If InStrRev(sString, "==") Then                     'InStrRev is faster when you know it's at the end.
        iPad = 2                                        'Note:  These translate to 0, so you can leave them...
    ElseIf InStrRev(sString, "=") Then                  'in the string and just resize the output.
        iPad = 1
    End If

    For lTemp = 0 To 255                                'Fill the translation table.
        Select Case lTemp
            Case 65 To 90
                bTrans(lTemp) = lTemp - 65              'A - Z
            Case 97 To 122
                bTrans(lTemp) = lTemp - 71              'a - z
            Case 48 To 57
                bTrans(lTemp) = lTemp + 4               '1 - 0
            Case 43
                bTrans(lTemp) = 62                      'Chr(43) = "+"
            Case 47
                bTrans(lTemp) = 63                      'Chr(47) = "/"
        End Select
    Next lTemp

    For lTemp = 0 To 63                                 'Fill the 2^6, 2^12, and 2^18 lookup tables.
        lPowers6(lTemp) = lTemp * cl2Exp6
        lPowers12(lTemp) = lTemp * cl2Exp12
        lPowers18(lTemp) = lTemp * cl2Exp18
    Next lTemp

    bIn = StrConv(sString, vbFromUnicode)               'Load the input byte array.
    ReDim bOut((((UBound(bIn) + 1) \ 4) * 3) - 1)       'Prepare the output buffer.

    For lChar = 0 To UBound(bIn) Step 4
        lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lChar + 1))) + _
                lPowers6(bTrans(bIn(lChar + 2))) + bTrans(bIn(lChar + 3))           'Rebuild the bits.
        lTemp = lQuad And clHighMask                    'Mask for the first byte
        bOut(lPos) = lTemp \ cl2Exp16                   'Shift it down
        lTemp = lQuad And clMidMask                     'Mask for the second byte
        bOut(lPos + 1) = lTemp \ cl2Exp8                'Shift it down
        bOut(lPos + 2) = lQuad And clLowMask            'Mask for the third byte
        lPos = lPos + 3
    Next lChar

    If iPad Then
        ReDim Preserve bOut(LBound(bOut) To UBound(bOut) - iPad) 'Chop off any extra bytes.
    End If

    Dim iFileOut As Integer
    iFileOut = VBA.FreeFile()
    Open VBA.Environ$("UserProfile") & "\Documents\###." & strMIMEtype For Binary As #iFileOut
    Put #iFileOut, , bOut()
    Close #iFileOut

    'StrConv(bOut, vbUnicode)                     'Convert back to a string.
    Decode64 = True

ExitProc:
    Exit Function

ErrControl:
    lgRetVal = VBA.MsgBox("Input string is not valid Base64.", vbCritical, "W A R N I N G")
    GoTo ExitProc
End Function

 

VBA validation list values

If you want to get the values that cell valuation can handle, use this piece of code:

Private Sub sGetValidationList()
If Intersect(ActiveSheet.Cells.SpecialCells(xlCellTypeAllValidation), Selection) Is Nothing Then
Else
Call fGetValidationList(Selection, ";")
End If
End Sub

Private Function fGetValidationList(ByVal Target As Excel.Range, _
Optional ByVal strSeparator As String = ",") As String()
Dim rgList As Range
Dim strList As String
Dim strWsh As String
Dim lgPosition As Long

Dim aValidation() As String
Dim myVar As Variant
Dim myItem As Variant
Dim lgItem As Long

If Intersect(Target.Parent.Cells.SpecialCells(xlCellTypeAllValidation), Target) Is Nothing Then
Else
' Get the formula in the data validation
strList = Target.Validation.Formula1

' Check if it has an = sign (case has a range or a named range)
If VBA.InStr(1, strList, "=") > 0 Then
lgPosition = VBA.InStr(1, strList, "!")
If lgPosition > 0 Then
lgPosition = 1
strWsh = VBA.Mid$(strList, 1, VBA.InStr(1, strList, "!") - 1)
strWsh = VBA.Replace$(strWsh, "=", "")
strWsh = VBA.Replace$(strWsh, "'", "")
strList = VBA.Mid$(strList, VBA.InStr(1, strList, "!") + 1)
myVar = ThisWorkbook.Worksheets(strWsh).Range(strList).Value2
Else
myVar = Target.Parent.Range(VBA.Replace$(strList, "=", "")).Value2
End If
Else
' Case with a set of valid values
If InStr(1, strList, strSeparator) > 0 Then
myVar = Split(strList, strSeparator)
Else
aValidation = VBA.Split(strList, vbCrLf)
End If
End If

ReDim Preserve aValidation(LBound(myVar, 1) To UBound(myVar, 1))
lgItem = LBound(aValidation) - 1
For Each myItem In myVar
lgItem = lgItem + 1
aValidation(lgItem) = myItem
Next myItem
Erase myVar
fGetValidationList = aValidation
End If

End Function
[/sourcecode]

JavaScript: editable and resizable table

I’m a complete newbie in JavaScript language, but I’m trying to get on it. For long I’ve wondering if via JavaScript an HTML cable can be edited and resized (not only by means of shape, but to add rows and columns).

So asking google I reached some pages where code were exposed. Some were for resizing, some were for editing, some were for adding rows and other to add columns, and finally others were for sort and reorder elements. They were so interesting alone for themselves, that I supposed that combined, they will be ashtonishing. So did I. And here is the final code (the source links from were the codes came from are referred as comments in the code).

As there is something wrong with the javaScript code parser of wordpress, the code is linked in this file.

Database maker

In last post we were talking about how to distinguish between type of variables. From there, we can try to see if for any given table we can extract characteristics and mount a functional analysis of the database from a sample set of the table.

For that to be achieved, something like the following Database analyser can be used. It will also detect link to Names so data can be restricted to some sources.

Note: it needs the functions from this post.

Option Explicit
Private Const g_Base As Long = 0

Private Sub sDataBase_Analyzer()
' Given a database table, characterize the fields
Dim rgTable As Excel.Range
Dim rgHeaders As Excel.Range
Dim rgColumn As Excel.Range
Dim oCell As Excel.Range
Dim oCellLinked As Excel.Range
Dim rgFormulas As Excel.Range
Dim oName As Excel.Name
Dim bName As Boolean
Dim bHeaders As Boolean
Dim aField() As String
Dim aCarrousel() As String
Dim lgField As Long
Dim strField As String
Dim lgDeclaration As Long
Dim lgDeclarationOld As Long
Dim lgItem As Long
Dim lgCarrousel As Long
Dim bCarrousel As Boolean

Set rgTable = Selection 'Application.InputBox(Prompt:="Select table", Title:="", Type:=8, Default:="$A$1")
If vbYes = VBA.MsgBox("Table has headers?", vbYesNo, "Headers on first row?") Then bHeaders = True

ReDim Preserve aField(g_Base To rgTable.Columns.Count - 1 + g_Base)

lgField = g_Base - 1
If bHeaders Then
Set rgHeaders = rgTable.Rows(1)
For Each oCell In rgHeaders.Columns.Cells
If Not IsEmpty(oCell) Then
lgField = lgField + 1
strField = VBA.Trim$(oCell.Value2)
strField = VBA.Replace$(strField, " ", "_")
aField(lgField) = strField

' Capitalize string...
'.............ToDo
End If
Next oCell
End If

lgField = g_Base - 1
For Each rgColumn In rgTable.Columns
lgDeclaration = 0
If Not IsEmpty(rgColumn.Value2(1, 1)) Then
lgField = lgField + 1
lgCarrousel = g_Base - 1
For Each oCell In rgColumn.Cells
If (bHeaders And oCell.Row = rgHeaders.Row) Then
lgDeclarationOld = VarDeclaration(oCell.Offset(1, 0).Value2)
Else
If Not IsEmpty(oCell) Then
lgDeclaration = VarDeclaration(oCell.value)
If VBA.Abs(lgDeclarationOld) < VBA.Abs(lgDeclarationOld) Then
If lgDeclarationOld = 32768 Then
aField(lgField) = VBA.Replace$(aField(lgField), " As Integer", " As Long")
Exit For
End If
ElseIf Not bHeaders Then
If VBA.Abs(oCell.value) >= 32768 Then
aField(lgField) = VBA.Replace$(aField(lgField), " As Integer", " As Long")
Exit For
End If
End If
Next oCell

Case Is = 2
aField(lgField) = aField(lgField) & " As Double"

' Find typical values:
For Each oCell In rgColumn.Cells
If Not (bHeaders And oCell.Row = rgHeaders.Row) Then
If 1.401298E-45 >= VBA.Abs(oCell.value) Or VBA.Abs(oCell.value) >= 3.402823E+38 Then
aField(lgField) = VBA.Replace$(aField(lgField), " As Single", " As Double")
Exit For
End If
ElseIf Not bHeaders Then
If 1.401298E-45 >= VBA.Abs(oCell.value) Or VBA.Abs(oCell.value) >= 3.402823E+38 Then
aField(lgField) = VBA.Replace$(aField(lgField), " As Single", " As Double")
Exit For
End If
End If
Next oCell

Case Is = 3
aField(lgField) = aField(lgField) & " As Date"

Case Is = 4
aField(lgField) = aField(lgField) & " As String"

On Error Resume Next
Set rgFormulas = rgColumn.SpecialCells(xlCellTypeFormulas).Cells
On Error GoTo 0

If Not rgFormulas Is Nothing Then ' Links to somewhere else
For Each oCell In rgColumn.SpecialCells(xlCellTypeFormulas).Cells
If oCell.Precedents.Count = 1 Then
Set oCellLinked = oCell.Precedents.Item(1)
For Each oName In oCell.Parent.Names
If Not Intersect(oCell.Precedents.Item(1), oName.RefersToRange) Is Nothing Then
If Not oName.Name Like "*_FilterDatabase" Then
If oName.RefersToRange.Columns.Count = 1 Then
bName = True ' --> oName.Name
Exit For
End If
End If
End If
Next oName
End If
If bName Then
Debug.Print oName.Name
Exit For
End If
Next oCell
Set rgFormulas = Nothing

Else
' Find validation list
lgCarrousel = g_Base
ReDim Preserve aCarrousel(g_Base To lgCarrousel)
aCarrousel(lgCarrousel) = rgColumn.Value2(1, 1)
For Each oCell In rgColumn.Cells
If VBA.Abs(lgDeclaration) = 4 Then 'String
If IsBoolean(oCell.Value2) Then
aField(lgField) = VBA.Replace$(aField(lgField), " As String", " As Boolean")
Exit For

ElseIf Not (Not aCarrousel) Then
bCarrousel = False
For lgItem = LBound(aCarrousel) To UBound(aCarrousel)
If Not (bHeaders And oCell.Row = rgHeaders.Row) Then
If aCarrousel(lgItem) = oCell.Value2 Then
bCarrousel = True
Exit For
End If
End If
Next lgItem
Else
bCarrousel = True
End If

If (bHeaders And Not (oCell.Row = rgHeaders.Row)) Or Not bHeaders Then
If Not bCarrousel Then
If Not IsEmpty(oCell.Value2) Then
lgCarrousel = lgCarrousel + 1
ReDim Preserve aCarrousel(g_Base To lgCarrousel)
aCarrousel(lgCarrousel) = oCell.Value2
End If
End If
End If
End If
Next oCell

' Find validation list
If bHeaders Then
If rgColumn.SpecialCells(xlCellTypeConstants).Cells.Count > UBound(aCarrousel) - LBound(aCarrousel) + 1 Then
Debug.Print VBA.Join(aCarrousel(), "/")
End If
Else
If rgColumn.SpecialCells(xlCellTypeConstants).Cells.Count > UBound(aCarrousel) - LBound(aCarrousel) Then
Debug.Print VBA.Join(aCarrousel(), "/")
End If
End If
End If

Case Is = -1: aField(lgField) = aField(lgField) & "() As Long"
Case Is = -2: aField(lgField) = aField(lgField) & "() As Double"
Case Is = -3: aField(lgField) = aField(lgField) & "() As Date"
Case Is = -4: aField(lgField) = aField(lgField) & "() As String"
End Select
End If
Next rgColumn
Stop

Debug.Print VBA.Join(aField(), vbNewLine)
End Sub

Public Function VarDeclaration(ByVal strVarCheck As String) As Long ' String
If IsLong(strVarCheck) Then
VarDeclaration = 1 'Long/Integer/Byte
If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -1 ' Is array
ElseIf IsDouble(strVarCheck) Then
VarDeclaration = 2 'Double/Single
If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -2 ' Is array
ElseIf IsDate(strVarCheck) Then
VarDeclaration = 3 'Date
If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -3 ' Is array
ElseIf IsString(strVarCheck) Then
VarDeclaration = 4 'String
'If VBA.InStr(1, strVarCheck, vbLf) > 0 Then VarDeclaration = -4 ' Is array
End If

End Function
[/sourcecode]

Is VarType/TypeName replacement functions

So we have the VarType and TypeName functions already implemented in VBA, but, they require variables as the feeder, no considering expressions.

How can we determine if a value is an Integer a Byte or a Long?, a Single or a Double?

Here are some functions that can help to filter the type of variables by their values:

Public Function IsDouble(ByVal value As Variant) As Boolean
If IsNumeric(value) Then IsDouble = Not IsLong(value)
End Function

Public Function IsSingle(ByVal value As Variant) As Boolean
IsSingle = IsDouble(value) And (1.401298E-45 <= VBA.Abs(value) Or VBA.Abs(value) <= 3.402823E+38)
End Function

Public Function IsLong(ByVal value As Variant) As Boolean
If IsNumeric(value) Then IsLong = (VBA.CLng(value) = VBA.Val(value))
End Function

Public Function IsInteger(ByVal value As Variant) As Boolean
IsInteger = (IsLong(value) And VBA.Abs(value) <= 32768)
End Function

Public Function IsByte(ByVal value As Variant) As Boolean
IsByte = (IsLong(value) And VBA.Abs(value) <= 255)
End Function

Public Function IsString(ByVal value As Variant) As Boolean
IsString = (VarType(value) = vbString)
End Function

Public Function IsBoolean(ByVal value As Variant) As Boolean
Dim strTrueLocal As String: strTrueLocal = VBA.CStr(True)
Dim strFalseLocal As String: strFalseLocal = VBA.CStr(False)
IsBoolean = IsString(value) And (VBA.UCase$(value) = "TRUE" _
Or VBA.UCase$(value) = strTrueLocal _
Or VBA.UCase$(value) = "FALSE" _
Or VBA.UCase$(value) = strFalseLocal)
End Function
[/sourcecode]

Translate

Sorry if code looks a little mess… the WordPress editor doesn’t like too much RegEx expressions, so you have to paste the RegEx at the end of this post.

I attach the macros that I composed to translate using the services of “Google translator”, “Bing translator”, “Linguee”.

I have not spent much time exploring the available languages, just point that the GoogleLanguageIds function already can handle most common languages and that the Bing translator provides the Klingon language. The implementation of Linguee is interesting as points to external reference texts, and although it does not give out a very clean result (probably should worked the MsgBox to show the HTML code formatted within the component, but I have not wanted to spend much more time); it is useful for reference.

I’ve explored several ways to achieve the translation using the avaliable services. My final objective was to translate a DOC file keeping all the formatting and styling in place. That part is not shown here, although code is the final working version, just ripping the Word procedures off (that part drove me nuts, and is part of a future add-in development).

Option Explicit

' The program requires references to the following:
'1. Microsoft Internet Controls (SHDocVw)(ieFrame.dll)
'2. Microsoft HTML Object Library
'3. Microsoft Shell Controls And Automation

Private oIE As Object    'SHDocVw.InternetExplorer
Private oIETmp As Object 'SHDocVw.InternetExplorer
Private hDoc As MSHTML.HTMLDocument     'Object: to refer to the HTML document returned
Private strURL As String
Private hElement As MSHTML.IHTMLElement
Private hCollection As MSHTML.IHTMLElementCollection
Private hNode As MSHTML.IHTMLDOMNode
Private hDOMDoc As MSHTML.IHTMLDOMNode2

' For UTF-8 URL Encoding
Private Const CP_UTF8 = 65001
Private Declare Function WideCharToMultiByte Lib "Kernel32" (ByVal CodePage As Long, ByVal dwflags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
' -----------------------------

Private Const strSHORTCODES As String = ",af,sq,ar,hy,az,eu,be,bn,bg,ca,zh-CN,hr,cs,da,nl,en,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"
Private Enum eLanguageId
    auto_detect = 0
    Afrikaans = 1
    Albanian = 2
    Arabic = 3
    Armenian = 4
    Azerbaijani = 5
    Basque = 6
    Belarusian = 7
    Bengali = 8
    Bulgarian = 9
    Catalan = 10
    Chinese = 11
    Croatian = 12
    Czech = 13
    Danish = 14
    Dutch = 15
    English = 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 sDoc_Translate()
' we should try http://www.statmt.org/moses/index.php?n=Main.HomePage
    Dim TransServer As String:  TransServer = "google"
    Dim LngFrom As String:  LngFrom = "spanish"
    Dim LngTo As String:    LngTo = "english"
    Dim strTextFrom As String
    
    If oIE Is Nothing Then fIE_Initialize
    
    msgbox getTranslation(strTextFrom, LngFrom, LngTo, TransServer)
        
    oIE.Visible = True

    Call fIE_Terminate
End Sub

'Public Sub sExcel_Translate()
'' Translate. Keep format...
'    Dim rgSelection As Excel.Range
'    Dim oCell As Excel.Range
'    Dim lgWord As Long
'    Dim lgWords As Long: lgWords = 0
'    Dim aWord() As String
'    Dim strTextFrom As String
'    Dim strTextTo As String
'
'    If Not loadExplorer(oIE) Then Exit Sub
'    If Not loadExplorer(oIETmp) Then Exit Sub
'
'    Set rgSelection = Selection
'    For Each oCell In rgSelection.Cells
'        If Not IsEmpty(oCell.Value2) Then
'        If Not IsNumeric(oCell.Value2) Then
'            strTextFrom = VBA.Trim$(oCell.Text)
'            strTextFrom = VBA.Replace$(strTextFrom, "  ", " ")
'            aWord() = VBA.Split(strTextFrom, " ")
'            If lgWords + UBound(aWord) - LBound(aWord) + 1 > 5000 Then
'                ' Delete contents
'                oCell.Value2 = vbNullString
'
'                ' Translate blocks (bunch of 5000 words)
'                Do
'                    strTextFrom = vbNullString
'                    For lgWord = LBound(aWord) To 4999
'                        strTextFrom = strTextFrom & " " & aWord(lgWord)
'                    Next lgWord
'                    oCell.Value2 = oCell.Value2 & getTranslation(strTextFrom, LngFrom, LngTo, TransServer)
'
'                    strTextFrom = vbNullString
'                    For lgWord = 5000 To UBound(aWord)
'                        strTextFrom = strTextFrom & " " & aWord(lgWord)
'                    Next lgWord
'                    aWord() = VBA.Split(strTextFrom, " ")
'                    lgWords = lgWords + UBound(aWord) - LBound(aWord) + 1 - 5000
'                Loop While lgWords > 5000
'                oCell.Value2 = oCell.Value2 & getTranslation(strTextFrom, LngFrom, LngTo, TransServer)
'            Else
'                oCell.Value2 = getTranslation(strTextFrom, LngFrom, LngTo, TransServer)
'            End If
'        End If
'        End If
'    Next oCell
'
'    Call closeExplorer(oIE)
'    Call closeExplorer(oIETmp)
'End Sub
'
'Private Sub sTranslate()
'' Select translation service: "google", "bing", "linguee"
'    Dim strService As String
'    Dim lgRetVal As Long
'
'    strService = VBA.InputBox("Select translation service: [google, bing, linguee]", "Service", "google")
'    lgRetVal = MsgBox(getTranslation("Lion", "english", "spanish", strService), vbInformation + vbOKOnly)
'End Sub
'
'Private Function loadExplorer(ByRef oIE As Object) As Boolean
'    On Error GoTo ErrControl
'
'    If oIE Is Nothing Then
'        Set oIE = CreateObject("InternetExplorer.Application")
'    End If
'    loadExplorer = True
'
'ExitProc:
'    On Error GoTo 0
'    Exit Function
'
'ErrControl:
'    GoTo ExitProc
'End Function
'
'Private Function closeExplorer(ByRef oIE As Object) As Boolean
'    On Error GoTo ErrControl
'
'    oIE.Quit
'    Set oIE = Nothing
'
'    closeExplorer = True
'
'ExitProc:
'    On Error GoTo 0
'    Exit Function
'
'ErrControl:
'    GoTo ExitProc
'End Function

Private Function getWordTranslated(ByVal strSourceString As String, _
                                   ByVal strInputLang As String, _
                                   ByVal strOutputLang As String, _
                                   Optional ByVal strService As String = "Google") As String
    Dim strTranslation As String
    
    Do
        strTranslation = getTranslation(VBA.Trim$(strSourceString), strInputLang, strOutputLang, strService)
    Loop While VBA.Right$(strTranslation, 3) = "..."
    
    getWordTranslated = strTranslation
End Function

Private Sub sTranslate()
    Dim strSourceString As String: strSourceString = "Aquí una prueba de esto/ que es una prueba"
    Dim strInputLang As String: strInputLang = "spanish"
    Dim strOutputLang As String: strOutputLang = "english"
    Dim strService As String: strService = "bing"

    MsgBox getTranslation(strSourceString, strInputLang, strOutputLang, strService)
End Sub

Following is the main translator procedure:

Private Function getTranslation(ByVal strSourceString As String, _
                                ByVal strInputLang As String, _
                                ByVal strOutputLang As String, _
                                Optional ByVal strService As String = "Google") As String
    Dim strURL As String
    Dim strRes As String

    Dim strInputLangId As String
    Dim strOutputLangId As String
    Dim strTranslationElementID As String
    Dim strTempOutput As String
    Dim strHTML As String
    Dim aCleaData() As String
    Dim lngLoop As Long
    Dim bQuitExplorer As Boolean
    Dim bComplete As Boolean

    If strSourceString = "" Then Exit Function
    
    'INPUT LANGUAGE
    strInputLang = VBA.LCase$(strInputLang)
    If strInputLang = "" Then
        strInputLangId = "auto"
    Else
        strInputLangId = GoogleLanguageIds(strInputLang)
    End If

    'OUTPUT LANGUAGE
    strOutputLang = VBA.LCase$(strOutputLang)
    strOutputLangId = GoogleLanguageIds(strOutputLang)

    If strInputLang <> vbNullString And strOutputLang <> vbNullString Then
        If oIE Is Nothing Then fIE_Initialize
        
        'open Explorer instance
        'oIE.Visible = False

        strService = VBA.Trim$(VBA.LCase$(strService))

        If strService = vbNullString Then strService = "google"

        If strService = "google" Then
            
            strURL = "https://translate.google.com/#view=home" & _
                     "&op=translate" & _
                     "&sl=" & strInputLangId & _
                     "&tl=" & strOutputLangId & _
                     "&text=" & URLEncode(strSourceString)
            
            'strURL = "http://translate.google.com/translate_a/t?client=t" & _
                     "&text=" & URLEncode(strSourceString) & _
                     "&hl=en" & _
                     "&sl=" & strInputLangId & _
                     "&tl=" & strOutputLangId & _
                     "&multires=1" & _
                     "&pc=0" & _
                     "&rom=1" & _
                     "&sc=1"
            
            'strURL = "https://translate.google.com/#" & _
                     strInputLangId & "/" & _
                     strOutputLangId & "/" & _
                     strSourceString
            
            strTranslationElementID = "tlid-translation translation"

        ElseIf strService = "bing" Then
            strURL = "http://www.bing.com/translator/?text=" & _
                     URLEncode(strSourceString, True) & _
                     "&from=" & strInputLangId & "/" & _
                     "&to=" & strOutputLangId
            strTranslationElementID = "t_txtoutblk"

        ElseIf strService = "linguee" Then
            strURL = "https://www.linguee.com/" & _
                     strInputLang & "-" & _
                     strOutputLang & _
                     "/search?source=auto" & _
                     "&query=" & URLEncode(strSourceString, True)

            'strURL = "https://www.linguee.es/" & _
                     getTranslation(strInputLang, "en", "es") & "-" & _
                     getTranslation(strOutputLang, "en", "es") & _
                     "/traduccion/" & _
                     URLEncode(strSourceString, True) & ".html"

            strTranslationElementID = "lingueecontent"
        End If

        'open website
        If fIE_Load(strURL, False) Then
            Call fIE_Document

            Do Until oIE.readyState = 4
                DoEvents
            Loop
    
            Do Until oIE.readyState = 4
                DoEvents
            Loop
    
            'Get return HTML code
            oIE.Visible = True
            
            ' get translated node item
            If strService = "google" Then
                bComplete = False
                Do
                    Set hCollection = hDoc.getElementsByClassName(strTranslationElementID)
                    If hCollection.Length = 1 Then
                        bComplete = True
                        For Each hElement In hCollection
                            strTempOutput = hElement.innerText
                        Next hElement
                    End If
                    If (VBA.Trim$(strTempOutput) = vbNullString And VBA.Trim$(strSourceString) <> vbNullString) Then
                        WordWait 5 'although is readyState = COMPLETE the oIE could be still working to get the DOM structure...
                    Else
                        bComplete = True
                    End If
                    If VBA.Right$(strTempOutput, 3) = "..." Then bComplete = False
                Loop Until bComplete
                getTranslation = strTempOutput
            Else
                getTranslation = oIE.Document.getElementById(strTranslationElementID).innerText
            End If
        End If

        'If bQuitExplorer Then
        '    oIE.Quit
        '    Set oIE = Nothing
        'End If
    Else
        getTranslation = vbNullString
    End If

End Function

For the Google service we need a procedure to select languages:

Private Function GoogleLanguageIds(ByVal strLang As String) As String
    Dim strLangIds As String
    Dim arrLangIds() As String
    Dim strId As String
    Dim intLoop As Integer

    GoogleLanguageIds = VBA.Switch(strLang = "chinese", "zh-CN", _
                                   strLang = "danish", "da", _
                                   strLang = "dutch", "nl", _
                                   strLang = "english", "en", _
                                   strLang = "french", "fr", _
                                   strLang = "german", "de", _
                                   strLang = "greek", "el", _
                                   strLang = "italian", "it", _
                                   strLang = "japanese", "ja", _
                                   strLang = "norwegian", "no", _
                                   strLang = "polish", "pl", _
                                   strLang = "portuguese", "pt", _
                                   strLang = "romanian", "ro", _
                                   strLang = "russian", "ru", _
                                   strLang = "spanish", "es", _
                                   strLang = "swedish", "sv", _
                                   strLang = "Turkish", "tr", _
                                   strLang = "ukrainian", "uk")
    
    'Dim LanguageId As eLanguageId
    'GoogleLanguageIds = VBA.Split(strSHORTCODES, ",")(LanguageId)
End Function

Instead of using the Internet Explorer object, we could have chosen the XMLHTTP object, much faster, but completely hidden from user. And one point I didn’t like, it is usually recognised as a robot, and banned; so I prefer keeping the IE way, the XMLHTTP is just for reference (and, if you are for using with an API key, this should be the way to go):

Private Function ServerXMLHTTPTranslate(ByVal strSourceString As String, _
                                        ByVal strInputLang As String, _
                                        ByVal strOutputLang As String, _
                                        Optional ByVal strService As String = "Google") As String
    Dim strURL As String
    Dim trans As String
    Dim oHTTP As Object
    Dim strInputLangId As String
    Dim strOutputLangId As String
    
    Set oHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    strURL = "https://translate.google.com/m?" & _
             "hl=" & strInputLangId & _
             "&sl=" & strInputLangId & _
             "&tl=" & strOutputLangId & _
             "&ie=UTF-8" & _
             "&prev=_m" & _
             "&q=" & URLEncode(strSourceString)
    With oHTTP
        .Open "GET", strURL, False
        .setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
        .send ("")
        If InStr(.responseText, "div dir=""ltr""") > 0 Then
            trans = ... here put the code mentioned outside this block of code (mess of the WordPress Plugin with RegEx expressions
            MsgBox UnEncodeURL(trans)
        Else
            MsgBox ("Error")
        End If
    End With
End Function

Private Function GoogleTranslateAPI(ByVal text As String, _
                                    ByVal srcLang As String, _
                                    ByVal resLang As String) As String
' Needs an API key
    Dim jsonProvider As Object
    Dim jsonResult As Object
    Dim jsonResultText As String
    Dim googleApiUrl As String
    Dim googleApiKey As String
    Dim resultText As String
    
    Set jsonProvider = CreateObject("MSXML2.ServerXMLHTTP")
    
    text = URLEncode(text)
'!!!!!!!!!!!!!!!!!
Stop
'https://cloud.google.com/translate/pricing?hl=en
'https://cloud.google.com/products/calculator/
'If you get a 403 error, add payment method
    googleApiKey = "..." ' GOOGLE API KEY
'!!!!!!!!!!!!!!!!!
    
    googleApiUrl = "https://translation.googleapis.com/language/translate/v2?key=" & googleApiKey & "&source=" & srcLang & "&target=" & resLang & "&q=" & text
    
    jsonProvider.Open "POST", googleApiUrl, False
    jsonProvider.setRequestHeader "Content-type", "application/text"
    jsonProvider.send ("")
    jsonResultText = jsonProvider.responseText
    
    'Set jsonResult = jsonProvider.ParseJson(jsonResultText)
    'Set jsonResult = jsonResult("data")
    'Set jsonResult = jsonResult("translations")
    'Set jsonResult = jsonResult(1)
    
    'resultText = jsonResult("translatedText")
    
    GoogleTranslateAPI = resultText
End Function

To deal with the Internet Explorer object, we can rely on these procedures:

Private Function fIE_Initialize(Optional ByRef bIEMedium As Boolean = False) As Boolean
    'open Internet Explorer in memory, and go to website
    'Dim oIE As New InternetExplorer
    'If oIE Is Nothing Then
    If bIEMedium Then
        'Set oIE = New InternetExplorerMedium
        Set oIE = CreateObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}") 'Internet Explorer Medium
        Set oIE = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}") 'Internet Explorer Medium
    Else
        Set oIE = CreateObject("InternetExplorer.Application")
        'Set oIE = New InternetExplorer
    End If
    'End If
    oIE.Visible = True
    
    fIE_Initialize = Not (oIE Is Nothing)
End Function

Private Function fIE_Load(Optional ByVal strURL As String = vbNullString, _
                          Optional ByVal bMedium As Boolean = False) As Boolean
    Dim Timer As Date
    
    If strURL = vbNullString Then
        strURL = VBA.InputBox("URL:", , "https://...")
    End If
    
    'Wait until IE is done loading page
    Err.Clear
    'On Error Resume Next
    oIE.navigate strURL '"http://", , , , "Content-Type: application/x-www-form-urlencoded" & vbCrLf
    Timer = VBA.Now()
    
    'On Error Resume Next
    While oIE.Busy
        Application.StatusBar = "Trying to connect..."
        DoEvents
    Wend
    
    If bMedium Then
        WordWait 5
    Else
        Do While oIE.readyState <> READYSTATE_COMPLETE
            'Application.StatusBar = "Trying to connect..."
            DoEvents
            'If (VBA.Now() - Timer) > 10000 Then 'Stop: End
        Loop
    End If
    If Err.Number = 462 Then
        If strURL Like "file:///*" Then
            fIE_Load = True
        Else
            ''Stop: End
            fIE_Load = False
        End If
    Else
        fIE_Load = True
    End If
    Err.Clear
    On Error GoTo 0
    
    Application.StatusBar = ""
End Function
    
Private Function fIE_Document() As Boolean
    'show text of HTML document returned
    Set hDoc = oIE.Document
    
    'save to file: hDoc.DocumentElement.innerHTML

    ' Also: ------------------------
    ''Create HTMLFile Object
    'Set hDoc = CreateObject("htmlfile")
    '
    ''Get the WebPage Content to HTMLFile Object
    'With CreateObject("msxml2.xmlhttp")
    '    .Open "GET", strURL, False
    '    .send
    '    '??? hDoc.body.innerHTML = .responseText
    'End With
    ' ------------------------------

End Function

Private Function fIE_Terminate() As Boolean 'ByVal oIE As InternetExplorer) 'Object

    Set hDoc = Nothing

    'close down IE and reset status bar
    ' oIE.Refresh ' Refresh if needed
    Set oIE = Nothing
    
    Application.StatusBar = ""

Err_Clear:
    If Err <> 0 Then
        Debug.Assert Err = 0
        Err.Clear
        'Resume Next
    End If
End Function

And we need some code to parse the text string to translate to the URL string, so we can feed the translator box:

Public Function UTF16To8(ByVal UTF16 As String) As String
    Dim sBuffer As String
    Dim lLength As Long
    
    If UTF16 <> "" Then
        lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, 0, 0, 0, 0)
        sBuffer = Space$(lLength)
        lLength = WideCharToMultiByte(CP_UTF8, 0, StrPtr(UTF16), -1, StrPtr(sBuffer), Len(sBuffer), 0, 0)
        sBuffer = StrConv(sBuffer, vbUnicode)
        UTF16To8 = Left$(sBuffer, lLength - 1)
    Else
        UTF16To8 = ""
    End If
End Function

Public Function URLEncode(ByVal strTextSource As String, _
                          Optional ByVal SpaceAsPlus As Boolean = False, _
                          Optional ByVal UTF8Encode As Boolean = True) As String

    Dim StringValCopy As String: StringValCopy = IIf(UTF8Encode, UTF16To8(strTextSource), strTextSource)
    Dim StringLen As Long:       StringLen = VBA.Len(StringValCopy)
    Dim Result() As String
    
    If StringLen > 0 Then
        ReDim Result(1 To StringLen)
        Dim lgChr As Long
        Dim CharCode As Integer
        Dim Char As String
        Dim Space As String
        
        If SpaceAsPlus Then Space = "+" Else Space = "%20"
        
        For lgChr = 1 To StringLen
            Char = Mid$(StringValCopy, lgChr, 1)
            CharCode = Asc(Char)
            Select Case CharCode
                Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
                    Result(lgChr) = Char
                Case 32
                    Result(lgChr) = Space
                Case 0 To 15
                    Result(lgChr) = "%0" & Hex(CharCode)
                Case Else
                    Result(lgChr) = "%" & Hex(CharCode)
            End Select
        Next lgChr
        URLEncode = Join(Result, "")
    End If

    ' It can also be achieved via JavaScript:
        'Dim ScriptEngine As ScriptControl: Set ScriptEngine = New ScriptControl
        'Dim ScriptEngine As Object: Set ScriptEngine = CreateObject("ScriptControl")
        'ScriptEngine.Language = "JScript"
        'ScriptEngine.AddCode "function encode(f) {return encodeURIComponent(f);}"
        'URLEncode = ScriptEngine.Run("encode", strTextSource)
        'Set ScriptEngine = Nothing

End Function

Public Function UnEncodeURL(ByVal URLEncoded As String) As String
' revert urlencoded characters to regular texts
    Dim ibyte As Integer
    Dim txt As String
    Dim hexChr As String

    txt = URLEncoded
    
    ' replace '+' with space
    txt = Replace(txt, "+", " ")
    
    For ibyte = 1 To 255
        Select Case ibyte
            Case 1 To 15: hexChr = "%0" & Hex(ibyte)
            Case 37: ' skip '%' character
            Case Else: hexChr = "%" & VBA.Hex(ibyte)
        End Select
        
        txt = VBA.Replace(txt, VBA.UCase$(hexChr), VBA.Chr(ibyte))
        txt = VBA.Replace(txt, VBA.LCase$(hexChr), VBA.Chr(ibyte))
    Next ibyte
    
    'replace '%' character
    txt = VBA.Replace(txt, "%25", "%")
    txt = VBA.Replace(txt, """, """")
    txt = VBA.Replace(txt, "%2C", ",")
    txt = VBA.Replace(txt, "'", "'")
    UnEncodeURL = txt
End Function

'Private Function xURLEncode(ByVal StringVal As String, _
'                           Optional ByVal SpaceAsPlus As Boolean = False) As String
''!!!!!!!!!!!!!!!!!
'' Not valid for UTF-8
''!!!!!!!!!!!!!!!!!
'    Dim StringLen As Long
'    StringLen = VBA.Len(StringVal)
'
'    Dim Result() As String
'    Dim I As Long
'    Dim CharCode As Integer
'    Dim Char As String
'    Dim Space As String
'
'    If StringLen > 0 Then
'        ReDim Result(StringLen)
'
'        If SpaceAsPlus Then Space = "+" Else Space = "%20"
'
'        For I = 1 To StringLen
'            Char = Mid$(StringVal, I, 1)
'            CharCode = Asc(Char)
'            Select Case CharCode
'                Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
'                    Result(I) = Char
'                Case 32
'                    Result(I) = Space
'                Case 0 To 15
'                    Result(I) = "%0" & Hex(CharCode)
'                Case Else
'                    Result(I) = "%" & Hex(CharCode)
'            End Select
'        Next I
'        xURLEncode = Join(Result, "")
'    End If
'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
    Dim regex As Object
    Dim matches As Object
    
    Set regex = CreateObject("VBScript.RegExp"): regex.Pattern = reg
    regex.Global = Not (matchIndex = 0 And subMatchIndex = 0) 'For 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

If you want to use Google or Microsoft API, here some links:

  • API microsoft: https://sysmod.wordpress.com/2012/01/09/microsoft-translator-vba-code-sample/ ((c) Patrick O’Beirne (@ExcelAnalytics))
  • API Google: https://stackoverflow.com/a/43273425 (requieres module JSonConverter VBA-JSON v2.2.3 (c) Tim Hall – https://github.com/VBA-tools/VBA-JSON

Following a list with the 104 languages supported by Google translator service (in spanish), taken from here.

LANGUAGE SHORT
afrikaans af
albanés sq
alemán de
amárico am
árabe ar
armenio hy
azerí az
bengalí bn
bielorruso be
birmano my
bosnio bs
búlgaro bg
camboyano (o jemer) km
canarés kn
catalán ca
cebuano ce
checo cs
chichewa ny
chino zh
chino tradicional zh
cingalés si
coreano ko
corso co
criollo haitiano ht
croata hr
danés da
eslovaco sk
esloveno sl
español (o castellano) es
esperanto eo
estonio et
euskera eu
finés (o finlandés) fi
francés fr
frisón (o frisio) fy
gaélico escocés gd
galés cy
gallego gl
georgiano ka
griego (moderno) el
guyaratí (o guyaratí) gu
hausa ha
hawuaiano ha
hebreo he
hindi (o hindú) hi
hmong hm
holandes nl
húngaro hu
igbo ig
indonesio id
inglés en
irlandés (o gaélico) ga
islandés is
italiano it
japonés ja
javanés jv
kazajo (o kazajio) kk
kirguís ky
kurdo ku
lao lo
latín la
letón lv
lituano lt
luxemburgués lb
macedonio mk
malayalam ml
malayo ms
malgache (o malagasy) mg
maltés mt
maorí mi
maratí mr
mongol mn
nepalí ne
noruego no
panyabí (o penyabi) pa
pastú (o pashto) ps
persa fa
polaco pl
portugués pt
rumano ro
ruso ru
samoano sm
serbio sr
sesotho st
shona sn
sindhi sd
somalí so
suajili sw
sueco sv
sundanés su
tagalo tl
tailandés th
tamil ta
tayiko tg
telugú te
turco tr
ucraniano uk
urdu ur
uzbeko uz
vietnamita vi
xhosa xh
yídish (o yiddish) yi
yoruba yo
zulú zu

Paste this code where indicated:
trans = RegexExecute(.responseText, “div[^””]*?””ltr””.*?>(.+?)

“)