# VBForums CodeBank > CodeBank - Visual Basic 6 and earlier >  VB - Fast Base64 Encoding and Decoding

## Comintern

Here's some code for encoding and decoding MIME Base64 (and _fast_).  On my machine it'll do around 2MB a second encoding and 1MB a second decoding.  The zip file contains both a class version (a little slower because of the overhead) and a module version.  Enjoy!  (yEnc encoder/decode to follow shortly).

EDIT:  Orig. zip removed, use the one below.

----------


## Agilaz

nice code, but....


VB Code:
Private Sub Command1_Click()
    Dim lCnt As Long
    
    For lCnt = 1 To 255
        IntegrityTest lCnt
    Next lCnt
    
End Sub
 Private Sub IntegrityTest(lLen As Long)
    Dim lCnt1 As Long, lCnt2 As Long
    Dim sOriginal As String, sEncoded As String, sDecoded As String
    Dim bytArr() As Byte
    
    ReDim bytArr(lLen) As Byte
    
    'create a binary string for testing
    
    Do
        bytArr(lCnt1) = lCnt2
        lCnt1 = lCnt1 + 1
        lCnt2 = lCnt2 + 1
        If lCnt2 = 256 Then lCnt2 = 0
    Loop Until lCnt1 > UBound(bytArr)
       
    sOriginal = StrConv(bytArr, vbUnicode)
    
    
    sEncoded = Encode64(sOriginal)
    
    sDecoded = Decode64(sEncoded)
    
    If sOriginal = sDecoded Then
        Debug.Print "Data integrity test passed!"; lLen
    Else
        Debug.Print "Data integrity test failed!"; lLen
    End If
    
End Sub

well, try that code and see yourself   :Ehh:

----------


## Comintern

Your test for equity will always fail if the length of the input string isn't divisible by 3.  Reason being, the string is passed to the encoder ByRef and is padded with nulls so that it's length _is_ divisible by 3.  That means that the string that is actually encoded correctly, but when you look for equity later in the test code you aren't comparing against what was actually encoded.  You can verify this by explicitly passing the strings to the encoding functions ByVal or passing it a copy of the string.

I would like to thank you for making me take a look at this again--there was an error that my testing didn't catch dealing with how the end padding key is placed when the encoded data ends with a CrLf.  That just needed a little one-line fix.

Here's my test code, 10000 random length strings between 1 and 1000 characters.


VB Code:
Private Sub IntegrityBas()
     Dim sOrig As String, sTest As String, sEnc As String, sDec As String, lRep As Long
    
    Randomize
    
    For lRep = 1 To 10000
        sOrig = TestString(Int(1000 * Rnd + 1))
        sTest = sOrig
        sEnc = Encode64(sTest)
        sDec = Decode64(sEnc)
        If sDec <> sOrig Then
            Debug.Print "Data integrity test failed!"
            Exit Sub
        End If
    Next lRep
    
    Debug.Print "Data integrity test passed!"
    
End Sub
 Private Sub IntegrityCls()
     Dim sOrig As String, sTest As String, sEnc As String, sDec As String, lRep As Long, oEnc As Base64
    
    Randomize
    Set oEnc = New Base64
    
    For lRep = 1 To 10000
        sOrig = TestString(Int(1000 * Rnd + 1))
        sTest = sOrig
        sEnc = oEnc.Encode(sTest)
        sDec = oEnc.Decode(sEnc)
        If sDec <> sOrig Then
            Debug.Print "Data integrity test failed!"
            Set oEnc = Nothing
            Exit Sub
        End If
    Next lRep
    
    Set oEnc = Nothing
    Debug.Print "Data integrity test passed!"
    
End Sub
 Private Function TestString(lLen As Long) As String
     Dim bTemp() As Byte, lPos As Long
    
    ReDim bTemp(lLen)
    For lPos = LBound(bTemp) To UBound(bTemp)
        bTemp(lPos) = Int((255 + 1) * Rnd)
    Next lPos
     TestString = StrConv(bTemp, vbUnicode)
 End Function

----------


## devincci1969

I tried the code using another language....Chinese to be precise.  It doesn't work.  :Frown:

----------


## Comintern

What problem are you running into?  This should encode any binary file, so the language of the file shouldn't be relevent.  If it is used to encode unicode strings, you will need to compensate for the implicit unicode conversions that VB6 performs.  Can you post a sample file for me to test with?

----------


## kbertone

ComIntern!  Your code looks good, but I am having trouble using it to encode data from a binary file in VB6.  Have tried bunch of different ways to get the data out of the file and into a string to give to your encoder function, but the base64 comes back wrong.  Could you post some VB6 example code as to how to do this?

I have tried stuff like InputB from the file into a string, reading the file into a Byte (byte by byte) and concatenating them into a string, etc, but nothing seems to work.

Thanks!

----------


## kbertone

Here is an example of some code that doesn't seem to return the right base64:


iFile = FreeFile()
Open txtAttachmentFile.Text For Binary Access Read Lock Write As #iFile
strAttachment = InputB(LOF(iFile), iFile)
Close #iFile

' convert attachment to base64
Set mybase64 = New Base64
strAttachment = mybase64.Encode(strAttachment)

----------


## Comintern

You're reading the file as ANSI into a Unicode string.  Use the Get function instead:


```
    iFile = FreeFile()
    Open txtAttachmentFile.Text For Binary Access Read Lock Write As #iFile
    strAttachment = String$(LOF(iFile), Chr$(0))
    Get #iFile, , strAttachment
    Close #iFile
```

----------


## kbertone

Thanks, O Great ComIntern.  Works like a charm!

----------


## JHart

Thank you very much for the code -- just what I was looking for!   :Thumb:  

- Joe

----------


## bearboss_85

This one help a lot in my project :




> You're reading the file as ANSI into a Unicode string.  Use the Get function instead:
> 
> 
> ```
>     iFile = FreeFile()
>     Open txtAttachmentFile.Text For Binary Access Read Lock Write As #iFile
>     strAttachment = String$(LOF(iFile), Chr$(0))
>     Get #iFile, , strAttachment
>     Close #iFile
> ```


But how to make it back to a single file when we want to decode it... I know that I need to convert it to binary first so that it can be converted into one single actual file. But I've got no idea in doing that plus I'm a beginner in VB6. Thanks....  :Big Grin:

----------


## Comintern

> This one help a lot in my project :
> 
> 
> 
> But how to make it back to a single file when we want to decode it... I know that I need to convert it to binary first so that it can be converted into one single actual file. But I've got no idea in doing that plus I'm a beginner in VB6. Thanks....


Try:


```
    iFile = FreeFile()
    Open file.bin For Binary As #iFile              'replace with the destination file name.
    Put #iFile, , sBinary
    Close #iFile
```

file.bin would be replaced with the output filename, sBinary would be the decoded string.

----------


## bearboss_85

I've got this originally from here :

http://www.vbforums.com/showthread.php?t=514815

It's my thread.. LaVolpe is helping a lot.. Since it's your code, I figure out that  I might want to asked your opinion as well... Here's the code:



```
Private Sub cmdDecode_Click()
Dim sBase64 As String
Dim sJPG As String
Dim iFile As Integer
Dim myClass As Class1

    cdSave.Filter = "Joint Photo Group (*.jpg)|*.jpg|Joint Photo Expert Group (*.jpeg)|*.jpeg"
    cdSave.ShowSave
    If Err Then
        ' This code runs if the dialog was cancelled
        MsgBox "Dialog Cancelled"
    Else
        Set myClass = New Class1
        iFile = FreeFile()
        Open Text2.Text For Binary Access Read Lock Write As #iFile
        sJPG = String$(LOF(iFile), 0)
        Get #iFile, , sJPG
        Close #iFile
    
        sBase64 = myClass.Decode(sJPG)
        iFile = FreeFile()
        Open cdSave.FileName For Binary As #iFile
        Put #iFile, , sBase64
        Close #iFile
    End If

End Sub
```

I've got this kind of error :

Run-time error '53'

File not found

 :Ehh:

----------


## Pteranodon

I am getting a "garbage at end of zipfile" message when trying to open a .zip file created with the decoded contents of a string using this decode code.  Different .zip programs, like Enzip and ZipCentral, give slightly different versions of the same message.

----------


## georgekar

Nice the above code but not for binary data in string. I do the correnctions.
1. Added ByVal for Encoder for input string
2. Change bIn = StrConv(sString, vbFromUnicode)  to use all the bytes in Encoder
         as bIn = sString
3. Removed sOut = StrConv(bOut, vbUnicode)   from Decoder to get all the bytes
          sOut = bOut
And now check the Test sub for results.



```
Option Explicit
Private Const clOneMask = 16515072          '000000 111111 111111 111111
Private Const clTwoMask = 258048            '111111 000000 111111 111111
Private Const clThreeMask = 4032            '111111 111111 000000 111111
Private Const clFourMask = 63               '111111 111111 111111 000000

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

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

Public Function Encode64(ByVal sString As String) As String

    Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte
    Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, 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)      This is fault         'Load the input string.
    bIn = sString              '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(sString As String) As String

    Dim bOut() As Byte, bIn() As Byte, bTrans(255) As Byte, lPowers6(63) As Long, lPowers12(63) As Long
    Dim lPowers18(63) As Long, lQuad As Long, iPad As Integer, lChar As Long, lPos As Long, sOut As String
    Dim lTemp 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
        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

    sOut = bOut ' StrConv(bOut, vbUnicode)    This is fault
    
    If iPad Then sOut = Left$(sOut, Len(sOut) - iPad)   'Chop off any extra bytes.
    Decode64 = sOut
End Function

Sub Test()
Dim a$, b$, c$
a$ = ChrW(1212) + ChrW(4545) + ChrW(2345)
Debug.Print AscW(Mid$(a$, 1, 1)), AscW(Mid$(a$, 2, 1)), AscW(Mid$(a$, 3, 1))
b$ = Encode64(a$)
Debug.Print b$, "Encode64"
c$ = Decode64(b$)
Debug.Print AscW(Mid$(c$, 1, 1)), AscW(Mid$(c$, 2, 1)), AscW(Mid$(c$, 3, 1))
a$ = "abcdefghik"
Debug.Print Decode64(Encode64(a$)) = a$
End Sub
```

----------


## wqweto

Just did some tests of Decode64 against CryptStringToBinary API version and a pure VB6 version that seems to be pretty optimized.

Here is the inner loop of FromBase64Array:

thinBasic Code:
'--- decode loop    lPtr = VarPtr(baOutput(0))    For lIdx = 0 To UBound(baInput) - 3 Step 4        lCh = laTable(baInput(lIdx + 0)) _            Or laTable(&H100 + baInput(lIdx + 1)) _            Or laTable(&H200 + baInput(lIdx + 2)) _            Or laTable(&H300 + baInput(lIdx + 3))        If lCh < 0 Then            Exit For        End If        Call CopyMemory(ByVal lPtr, lCh, 3)        lPtr = (lPtr Xor &H80000000) + 3 Xor &H80000000    Next
To my surprise the pure VB6 version seems to be faster than API version when compiled.



Decode64 is lagging even more in the IDE -- up to 6-times slower and FromBase64Array reaches 100MB/s decoding speed on my machine.

Test project in the attachment.

cheers,
</wqw>

----------


## georgekar

I do some serius job here;
Advanced Decoder;
Encoder and Decoder  works nice. Spaces and Cr and Lf dropped at decoding not with  replace().  If we place a non proper char in a string for decoding,  decoder stop decoding and decide if it is a proper encoding string or  raise an error.
Also I found the problem with Encoder, when we have a Cr code and then place = (61). The solution was an extra Dim Presereve.




```
Option Explicit
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Const clOneMask = 16515072          '000000 111111 111111 111111
Private Const clTwoMask = 258048            '111111 000000 111111 111111
Private Const clThreeMask = 4032            '111111 111111 000000 111111
Private Const clFourMask = 63               '111111 111111 111111 000000

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

Private Const cl2Exp18 = 262144             '2 to the 18th power
Private Const cl2Exp12 = 4096               '2 to the 12th
Private Const cl2Exp6 = 64                  '2 to the 6th
Private Const cl2Exp8 = 256                 '2 to the 8th
Private Const cl2Exp16 = 65536              '2 to the 16th
' Refubrish By GeorgeKar
Public Function Encode64(sString As String) As String

    Dim bTrans(63) As Byte, lPowers8(255) As Long, lPowers16(255) As Long, bOut() As Byte, bIn() As Byte
    Dim lChar As Long, lTrip As Long, iPad As Integer, lLen As Long, lTemp As Long, lPos As Long, 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
    ReDim bIn(0 To Len(sString) * 2 - 1 + iPad)
    CopyMemory bIn(0), ByVal StrPtr(sString), Len(sString) * 2
    lLen = ((UBound(bIn) + 1) \ 3) * 4                  'Length of resulting string.
    ' set to 60 wchar for each line break
    lTemp = lLen \ 60                                   '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 = 60 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
    ReDim Preserve bOut(lPos - 1)
    lOutSize = lPos - 1
    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(sString As String) As String
    Dim ok As Boolean
    ok = True
    If Len(sString) = 0 Then Exit Function
    Dim bOut() As Byte, bIn() As Byte, bTrans(255) As Byte, lPowers6(63) As Long, lPowers12(63) As Long
    Dim lPowers18(63) As Long, lQuad As Long, iPad As Integer, lChar As Long, lPos As Long, sOut As String
    Dim lTemp As Long
    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 + 4)     'Prepare the output buffer.
    lChar = 0
    Dim lChar2 As Long, lChar3 As Long, lchar1 As Long
    Dim ubnd As Long
    ubnd = UBound(bIn)
    lChar3 = lChar - 1
    Do
        lChar = lChar3 + 1
        If lChar >= ubnd Then lChar3 = lChar: GoTo finish
        ok = False
        Do
        Select Case bIn(lChar)
            Case 65 To 90, 97 To 122, 48 To 57, 43, 47
                Exit Do
            Case 61
                lChar3 = lChar: GoTo finish
                Exit Do
            Case 10, 13, 32
                lChar = lChar + 1
            If lChar > ubnd Then lChar3 = lChar: GoTo finish
                Case Else
            lChar = lChar + 1
                lChar3 = lChar: GoTo finish
                GoTo finish
        End Select
        Loop
        lchar1 = lChar + 1
        If lchar1 > ubnd Then lChar3 = lchar1: GoTo finish
        Do
        Select Case bIn(lchar1)
            Case 65 To 90, 97 To 122, 48 To 57, 43, 47
                Exit Do
            Case 61
                lChar3 = lchar1: GoTo finish
            Case 10, 13, 32
                lchar1 = lchar1 + 1
                If lchar1 > ubnd Then lChar3 = lchar1: GoTo finish
            Case Else
                lchar1 = lchar1 + 1
                lChar3 = lchar1: GoTo finish
            End Select
        Loop
        lChar2 = lchar1 + 1
        If lChar2 > ubnd Then lChar3 = lChar2: GoTo finish
        Do
        Select Case bIn(lChar2)
            Case 65 To 90, 97 To 122, 48 To 57, 43, 47
                Exit Do
            Case 61
                lChar3 = lChar2: GoTo finish
                Exit Do
            Case 10, 13, 32
                lChar2 = lChar2 + 1
                If lChar2 > ubnd Then lChar3 = lChar2: GoTo finish
            Case Else
                lChar2 = lChar2 + 1
                lChar3 = lChar2: GoTo finish
            End Select
        Loop
        lChar3 = lChar2 + 1
        If lChar3 > ubnd Then GoTo finish
        Do
        Select Case bIn(lChar3)
            Case 65 To 90, 97 To 122, 48 To 57, 43, 47
                Exit Do
            Case 61
                GoTo finish
            Case 10, 13, 32
                lChar2 = lChar2 + 1
                If lChar2 > ubnd Then lChar3 = lChar2: GoTo finish
            Case Else
                lChar3 = lChar3 + 1
                If lChar3 > ubnd Then GoTo finish
                GoTo finish
        End Select
        Loop
        ok = True
        lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lchar1))) + _
                lPowers6(bTrans(bIn(lChar2))) + bTrans(bIn(lChar3))           '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
    Loop
finish:
    If Not ok Then
    iPad = 0
    Dim offset As Long
        Do While lChar3 + iPad + offset < ubnd
        Select Case bIn(lChar3 + iPad + offset)
            Case 10, 13, 32
            offset = offset + 1
            Case 61
            iPad = iPad + 1
            Case Else
            If (lChar3 + iPad + offset + 3) Mod 4 <> 0 Then GoTo error1
             bIn(lChar3 + iPad + offset) = 0
             bIn(lChar3 + iPad + offset + 1) = 0
             bIn(lChar3 + iPad + offset + 2) = 0
             bIn(lChar3 + iPad + offset + 3) = 0
             'lChar3 = lChar + 1
            Exit Do
        End Select
        Loop
        lChar3 = lChar3 + offset
        If iPad > 2 Then GoTo error1
        If iPad = 0 Then
            If (lPos + 2) Mod 3 + 1 <> 3 Then
                GoTo error1
            End If
        Else
            If (lPos + 3 - iPad) Mod 3 + iPad <> 3 Then
                GoTo error1
            End If
        End If
 
        ok = True
        If lChar3 > ubnd Then GoTo cont1
        If lChar = lChar3 Then
            lChar = lChar + 1: lChar3 = lChar3 + 1
            lchar1 = lChar3
            lChar2 = lChar3
        End If
        If lchar1 = lChar3 Then
            lchar1 = lchar1 + 1: lChar3 = lChar3 + 1
            lChar2 = lChar3
        End If
        If lChar2 = lChar3 Then
            lChar2 = lChar2 + 1: lChar3 = lChar3 + 1
        End If
        If lChar3 <= ubnd Then
            lQuad = lPowers18(bTrans(bIn(lChar))) + lPowers12(bTrans(bIn(lchar1))) + _
            lPowers6(bTrans(bIn(lChar2))) + bTrans(bIn(lChar3))           '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
        End If
        lPos = lPos + 2 - iPad


        GoTo cont1
error1:
            Call Err.Raise(vbObjectError, "MyDecode", "Input string is not valid Base64.")
            Exit Function
    End If
cont1:

    sOut = String$((lPos + 1) \ 2, Chr(0))
    CopyMemory ByVal StrPtr(sOut), bOut(0), Len(sOut) * 2
    Decode64 = sOut
End Function
```

----------


## georgekar

After some thoughts I found why earlier versions loose the last byte from an odd length byte ansi string.
First problem was on Encoder, which use Len() and not LenB() to find the length of string. The second problem was on decoder, to feed the returned string with one byte more. The solution was to make a string as ansi, with the odd length and then copy the final bytes to that string.

New to this version, except for handling odd length byte data:
1. Compact the encoded string, means without Vbcrlf in each 60 output chars
2. Added Left Margin, so we can insert in each line some space at the left
3. Spaces and Cr/Lf can be anywhere in string to decode
4. Abnormal character stop algorithm, or ACS. When a byte to decode is not in the normal character list to decode, stop the decoding returning decoding bytes at that point. There is a flag from decoder which turn to false if no decoding can be done (which means that ACS can't apply).
5. There is a FileToEncode64() additional function to get any file as Encode64, without feeding a string before encoding

George

----------


## jnieto

> After some thoughts I found why earlier versions loose the last byte from an odd length byte ansi string.
> First problem was on Encoder, which use Len() and not LenB() to find the length of string. The second problem was on decoder, to feed the returned string with one byte more. The solution was to make a string as ansi, with the odd length and then copy the final bytes to that string.
> 
> New to this version, except for handling odd length byte data:
> 1. Compact the encoded string, means without Vbcrlf in each 60 output chars
> 2. Added Left Margin, so we can insert in each line some space at the left
> 3. Spaces and Cr/Lf can be anywhere in string to decode
> 4. Abnormal character stop algorithm, or ACS. When a byte to decode is not in the normal character list to decode, stop the decoding returning decoding bytes at that point. There is a flag from decoder which turn to false if no decoding can be done (which means that ACS can't apply).
> 5. There is a FileToEncode64() additional function to get any file as Encode64, without feeding a string before encoding
> ...


Hi, I'm new to visual basic.

Using the first excel code from the author of the thread worked for me. It encoded something (wrong), but it encoded. I'm Spanish and when I try to encode something with the first code... I get errors in the accent marks...

I thought it was because of what you mentioned in the thread, the issue of being ANSI, but when I try to use your modified code I get errors and it doesn't get to modify.

An error appears in Excel when compiling and something about 64 bits... as I'm telling you, I'm new to this but I'd like to learn. Forgive my ignorance and thanks for your time.

----------


## georgekar

I check the code with a spanish paragraph. The problem with my example for using the encoder/decoder is about the non unicode textboxes, not the encoder/decoder. So reading Text property from text boxes you get a Utf16Le encoded string from an ansi string based on selected font/language. The same for the output which a convertion happen from Utf16Le to the selected language on output Textbox, which is the same as the input when decode the encoded string (we show this in the second textbox).

I use this:
¿Queréis tener Netflix en casa 🏠, pero pagando un poco menos? La plataforma está a punto de lanzar una nueva suscripción para clientes ahorradores: el plan «Básico con Anuncios». Es igual que el plan Básico pero, como su nombre indica, contiene publicidad.
And convert to this:
vwBRAHUAZQByAOkAaQBzACAAdABlAG4AZQByACAATgBlAHQAZgBsAGkAeAAgAGUA
bgAgAGMAYQBzAGEAIAA82ODfLAAgAHAAZQByAG8AIABwAGEAZwBhAG4AZABvACAA
dQBuACAAcABvAGMAbwAgAG0AZQBuAG8AcwA/ACAATABhACAAcABsAGEAdABhAGYA
bwByAG0AYQAgAGUAcwB0AOEAIABhACAAcAB1AG4AdABvACAAZABlACAAbABhAG4A
egBhAHIAIAB1AG4AYQAgAG4AdQBlAHYAYQAgAHMAdQBzAGMAcgBpAHAAYwBpAPMA
bgAgAHAAYQByAGEAIABjAGwAaQBlAG4AdABlAHMAIABhAGgAbwByAHIAYQBkAG8A
cgBlAHMAOgAgAGUAbAAgAHAAbABhAG4AIACrAEIA4QBzAGkAYwBvACAAYwBvAG4A
IABBAG4AdQBuAGMAaQBvAHMAuwAuACAARQBzACAAaQBnAHUAYQBsACAAcQB1AGUA
IABlAGwAIABwAGwAYQBuACAAQgDhAHMAaQBjAG8AIABwAGUAcgBvACwAIABjAG8A
bQBvACAAcwB1ACAAbgBvAG0AYgByAGUAIABpAG4AZABpAGMAYQAsACAAYwBvAG4A
dABpAGUAbgBlACAAcAB1AGIAbABpAGMAaQBkAGEAZAAuAA==

Here is the code in M2000 Interpreter which use the same encoder/decoder. You can see the funtions here: https://github.com/M2000Interpreter/.../main/pipe.bas



The textbox of M2000 is a unicode textbox (which I create). So there is no convertion to Ansi.

You can check the output here (as you see, you have to inform that the encoding is Utf16LE:

----------

