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

 

Leave a Reply

Your email address will not be published. Required fields are marked *