VB - Fast Base64 Encoding and Decoding-VBForums
Results 1 to 18 of 18

Thread: VB - Fast Base64 Encoding and Decoding

  1. #1

    Thread Starter
    Fanatic Member Comintern's Avatar
    Join Date
    Nov 2004
    Location
    Lincoln, NE
    Posts
    826

    VB - Fast Base64 Encoding and Decoding

    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.
    Last edited by Comintern; Jul 10th, 2006 at 10:08 AM.

  2. #2
    Lively Member Agilaz's Avatar
    Join Date
    Jun 2006
    Posts
    98

    Re: VB - Fast Base64 Encoding and Decoding

    nice code, but....

    VB Code:
    1. Private Sub Command1_Click()
    2.     Dim lCnt As Long
    3.    
    4.     For lCnt = 1 To 255
    5.         IntegrityTest lCnt
    6.     Next lCnt
    7.    
    8. End Sub
    9.  
    10. Private Sub IntegrityTest(lLen As Long)
    11.     Dim lCnt1 As Long, lCnt2 As Long
    12.     Dim sOriginal As String, sEncoded As String, sDecoded As String
    13.     Dim bytArr() As Byte
    14.    
    15.     ReDim bytArr(lLen) As Byte
    16.    
    17.     'create a binary string for testing
    18.    
    19.     Do
    20.         bytArr(lCnt1) = lCnt2
    21.         lCnt1 = lCnt1 + 1
    22.         lCnt2 = lCnt2 + 1
    23.         If lCnt2 = 256 Then lCnt2 = 0
    24.     Loop Until lCnt1 > UBound(bytArr)
    25.        
    26.     sOriginal = StrConv(bytArr, vbUnicode)
    27.    
    28.    
    29.     sEncoded = Encode64(sOriginal)
    30.    
    31.     sDecoded = Decode64(sEncoded)
    32.    
    33.     If sOriginal = sDecoded Then
    34.         Debug.Print "Data integrity test passed!"; lLen
    35.     Else
    36.         Debug.Print "Data integrity test failed!"; lLen
    37.     End If
    38.    
    39. End Sub

    well, try that code and see yourself

  3. #3

    Thread Starter
    Fanatic Member Comintern's Avatar
    Join Date
    Nov 2004
    Location
    Lincoln, NE
    Posts
    826

    Re: VB - Fast Base64 Encoding and Decoding

    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:
    1. Private Sub IntegrityBas()
    2.  
    3.     Dim sOrig As String, sTest As String, sEnc As String, sDec As String, lRep As Long
    4.    
    5.     Randomize
    6.    
    7.     For lRep = 1 To 10000
    8.         sOrig = TestString(Int(1000 * Rnd + 1))
    9.         sTest = sOrig
    10.         sEnc = Encode64(sTest)
    11.         sDec = Decode64(sEnc)
    12.         If sDec <> sOrig Then
    13.             Debug.Print "Data integrity test failed!"
    14.             Exit Sub
    15.         End If
    16.     Next lRep
    17.    
    18.     Debug.Print "Data integrity test passed!"
    19.    
    20. End Sub
    21.  
    22. Private Sub IntegrityCls()
    23.  
    24.     Dim sOrig As String, sTest As String, sEnc As String, sDec As String, lRep As Long, oEnc As Base64
    25.    
    26.     Randomize
    27.     Set oEnc = New Base64
    28.    
    29.     For lRep = 1 To 10000
    30.         sOrig = TestString(Int(1000 * Rnd + 1))
    31.         sTest = sOrig
    32.         sEnc = oEnc.Encode(sTest)
    33.         sDec = oEnc.Decode(sEnc)
    34.         If sDec <> sOrig Then
    35.             Debug.Print "Data integrity test failed!"
    36.             Set oEnc = Nothing
    37.             Exit Sub
    38.         End If
    39.     Next lRep
    40.    
    41.     Set oEnc = Nothing
    42.     Debug.Print "Data integrity test passed!"
    43.    
    44. End Sub
    45.  
    46. Private Function TestString(lLen As Long) As String
    47.  
    48.     Dim bTemp() As Byte, lPos As Long
    49.    
    50.     ReDim bTemp(lLen)
    51.     For lPos = LBound(bTemp) To UBound(bTemp)
    52.         bTemp(lPos) = Int((255 + 1) * Rnd)
    53.     Next lPos
    54.  
    55.     TestString = StrConv(bTemp, vbUnicode)
    56.  
    57. End Function
    Attached Files Attached Files

  4. #4
    New Member
    Join Date
    Aug 2006
    Posts
    1

    Re: VB - Fast Base64 Encoding and Decoding

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

  5. #5

    Thread Starter
    Fanatic Member Comintern's Avatar
    Join Date
    Nov 2004
    Location
    Lincoln, NE
    Posts
    826

    Re: VB - Fast Base64 Encoding and Decoding

    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?

  6. #6
    New Member
    Join Date
    Apr 2007
    Posts
    3

    Re: VB - Fast Base64 Encoding and Decoding

    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!

  7. #7
    New Member
    Join Date
    Apr 2007
    Posts
    3

    Re: VB - Fast Base64 Encoding and Decoding

    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)

  8. #8

    Thread Starter
    Fanatic Member Comintern's Avatar
    Join Date
    Nov 2004
    Location
    Lincoln, NE
    Posts
    826

    Re: VB - Fast Base64 Encoding and Decoding

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

  9. #9
    New Member
    Join Date
    Apr 2007
    Posts
    3

    Re: VB - Fast Base64 Encoding and Decoding

    Thanks, O Great ComIntern. Works like a charm!

  10. #10
    New Member
    Join Date
    Apr 2007
    Posts
    1

    Smile Re: VB - Fast Base64 Encoding and Decoding

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

    - Joe

  11. #11
    Junior Member
    Join Date
    Sep 2007
    Posts
    17

    Re: VB - Fast Base64 Encoding and Decoding

    This one help a lot in my project :

    Quote Originally Posted by Comintern
    You're reading the file as ANSI into a Unicode string. Use the Get function instead:
    Code:
        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....

  12. #12

    Thread Starter
    Fanatic Member Comintern's Avatar
    Join Date
    Nov 2004
    Location
    Lincoln, NE
    Posts
    826

    Re: VB - Fast Base64 Encoding and Decoding

    Quote Originally Posted by bearboss_85
    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:
    Code:
        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.

  13. #13
    Junior Member
    Join Date
    Sep 2007
    Posts
    17

    Re: VB - Fast Base64 Encoding and Decoding

    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:

    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


  14. #14
    Lively Member
    Join Date
    Oct 2007
    Posts
    126

    Re: VB - Fast Base64 Encoding and Decoding

    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.

  15. #15
    Fanatic Member
    Join Date
    May 2014
    Location
    Preveza Greece
    Posts
    911

    Re: VB - Fast Base64 Encoding and Decoding

    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.

    Code:
    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

  16. #16
    Hyperactive Member wqweto's Avatar
    Join Date
    May 2011
    Posts
    480

    Re: VB - Fast Base64 Encoding and Decoding

    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:
    1. '--- decode loop
    2.     lPtr = VarPtr(baOutput(0))
    3.     For lIdx = 0 To UBound(baInput) - 3 Step 4
    4.         lCh = laTable(baInput(lIdx + 0)) _
    5.             Or laTable(&H100 + baInput(lIdx + 1)) _
    6.             Or laTable(&H200 + baInput(lIdx + 2)) _
    7.             Or laTable(&H300 + baInput(lIdx + 3))
    8.         If lCh < 0 Then
    9.             Exit For
    10.         End If
    11.         Call CopyMemory(ByVal lPtr, lCh, 3)
    12.         lPtr = (lPtr Xor &H80000000) + 3 Xor &H80000000
    13.     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>
    Attached Files Attached Files
    Last edited by wqweto; Apr 14th, 2018 at 08:53 AM.

  17. #17
    Fanatic Member
    Join Date
    May 2014
    Location
    Preveza Greece
    Posts
    911

    Re: VB - Fast Base64 Encoding and Decoding

    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.


    Code:
    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
    Last edited by georgekar; Apr 15th, 2018 at 06:18 AM.

  18. #18
    Fanatic Member
    Join Date
    May 2014
    Location
    Preveza Greece
    Posts
    911

    New Version Handle ANSI & Unicode Strings

    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
    Attached Images Attached Images  
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width