'===========================================================================
' Subject: BASE64 ENCODER/DECODER FOR QB     Date: 01-16-99 (10:59)       
' Author:  Marc van den Dikkenberg           Code: QB, QBasic, PDS        
' Origin:  excel@xs4all.nl                 Packet: BINARY.ABC
'===========================================================================
DECLARE FUNCTION DECODE64$ (szEncoded AS STRING, iEndOfText AS INTEGER)
DECLARE FUNCTION ENCODE64$ (szUnEncoded AS STRING)
DECLARE SUB InitDecode64 ()

'-------------------------------------------------------------------------
' BASE64 Encoding / Decoding
' Original VBDOS Version by G. Balla, 1996 (Public Domain)
' QB 4.5 Conversion by Marc van den Dikkenberg, 1999
'--------------------------------------------------------------------------

DIM SHARED icChopMask  AS INTEGER  ' Constant 8-bit mask (Faster than using string constants)
DIM SHARED icBitShift  AS INTEGER  ' Constant shift mask (Faster than using string constants)
DIM SHARED icStartMask AS INTEGER  ' Initial mask value  (Faster than using string constants)

DIM SHARED iRollOver   AS INTEGER  ' Decoded Roll over value
DIM SHARED iHighMask   AS INTEGER  ' Mask high bits of each char
DIM SHARED iShift      AS INTEGER  ' Multiplier shift value
DIM SHARED iLowShift   AS INTEGER  ' Mask low bits of each char

DIM SHARED szAlphabet  AS STRING   ' Decode/Encode Lookup Table
DIM SHARED szTemp      AS STRING   ' Working string

Original$ = "This is a test-string!"
A$ = ENCODE64$(Original$)
PRINT A$

InitDecode64

B$ = DECODE64$(A$, -1)
PRINT B$

'----------------------------------------------------------------------------------------------
' Name:         DECODE64$
' Type:         String function
' Description:  decodes a string from BASE64 to binary format
'
' Arguements:   Source string to decode (szEncoded)
'               Last string in file to decode flag (iEndOfText)
' Returns:      Un-Encoded binary string.
'
' Errors:       Generates an Error via ERROR statement.
' Error code:   253 = No string to decode
'                   -----------------------------------------------
' NOTES:    Must call INITDECODE64 before sending 1st string of an encoded file.
'
'           A DOEVENTS occurs near the end of the FOR/NEXT loop
'                   -----------------------------------------------
' Global variables: szAlphabet         ' Decode/Encode lookup table
'                   szTemp             ' Working string
'
'                   iRollOver          ' Decode/Encode rollover value
'                   iHighMask          ' High bit mask
'                   iShift             ' Multiplier value
'
'
' Local variables:  iChar              ' Ascii Char value from Encoded string
'                   iPtr               ' Lookup table pointer
'                   iCounter           ' FOR/NEXT counter
'
'----------------------------------------------------------------------------------------------
FUNCTION DECODE64$ (szEncoded AS STRING, iEndOfText AS INTEGER)

' Create variables
    DIM iPtr       AS INTEGER
    DIM iChar      AS INTEGER
    DIM iCounter AS INTEGER

' Check if empty decoded string.
' If Empty, return NUL and Generate error 254
    IF LEN(szEncoded) = 0 THEN
        DECODE64$ = ""
        ERROR 253
        EXIT FUNCTION
    END IF

' Initialize working string
    szTemp = ""

' Begin Decoding
    FOR iCounter = 1 TO LEN(szEncoded)

' Get next alphabet
        iChar = ASC(MID$(szEncoded, iCounter, 1))

' Get Decoded value
        iPtr = INSTR(szAlphabet, CHR$(iChar)) - 1

' Check if character is valid
        IF iPtr >= 0 THEN

' Char is valid, process it
            IF iShift = icBitShift THEN

' 1st char in block of 4, keep high part of character
                iRollOver = (iPtr * iShift) AND icChopMask

' Reset masks for next character
                iHighMask = &H30
                iLowShift = icStartMask
                iShift = icStartMask

            ELSE

' Start saving decoded character
                szTemp = szTemp + CHR$(iRollOver OR ((iPtr AND iHighMask) / iLowShift))

' Calculate next mask and shift values
                iRollOver = (iPtr * iShift) AND icChopMask
                iShift = iShift * icBitShift
                iHighMask = (iHighMask \ icBitShift) OR &H30
                iLowShift = iLowShift / icBitShift

                IF iShift > 256 THEN
                    iShift = icBitShift
                    iLowShift = 0
                END IF
            END IF

        END IF
    NEXT

' Concat last character if required
    IF (iShift > icBitShift AND iShift < 256) THEN

' Character remaining in    iRollOver
        IF iEndOfText THEN

' Last string to decode in file
            szTemp = szTemp + CHR$(iRollOver)
        END IF
    END IF

' Exit wth decoded string
    DECODE64$ = szTemp
END FUNCTION

'----------------------------------------------------------------------------------------------
' Name:         ENCODE64$
' Type:         String function
' Description:  Encodes a string into a BASE64 coded string
'
' Arguement:    Source string to encode (szUnEncoded)
' Returns:      Encoded BASE64 string.
'
' Errors:       Generates an Error via ERROR statement.
' Error code:   254 = No string to encode
'                       returns NUL string
'                   -----------------------------------------------
' NOTES:    If sending more than 1 string per file, ensure that each source string
'               is a multiple of 3 bytes or premature padded characters are added.
'               The last string of a file is exempt from this rule.
'
'           Each string can be 16383 bytes in length to satisfy VB's string capacity limitation.
'
'           Encoded blocks should be written as sub block lengths of about 76 characters and
'               added CR/LF added to each sub-block.
'               This is what WINCODE does and should satisfy most UUE browsers.
'
'           A DOEVENT occurs near the end of the FOR/NEXT loop
'
'                   -----------------------------------------------
' Global variables: szAlphabet     ' Encoding/Decoding lookup table
'                   szTemp         ' Working string
'                   icChopMask     ' Constant 8-bit mask for speed
'                   icBitShift     ' Constant shift mask for speed
'
'                   iRollOver      ' Decode/Encode rollover value
'                   iHighMask      ' High bit mask
'                   iShift         ' Multiplier value
'
' Local variables:  icLowFill      ' Constant Low 2-bit fill value for speed
'
'                   iLowMask       ' Low bits mask
'                   iChar          ' Ascii char value from Un coded string
'                   iPtr           ' Lookup table pointer
'
'                   iCounter       ' For/Next loop counter
'----------------------------------------------------------------------------------------------
FUNCTION ENCODE64$ (szUnEncoded AS STRING)

' Create variables
    DIM icLowFill  AS INTEGER

    DIM iChar      AS INTEGER
    DIM iLowMask   AS INTEGER
    DIM iPtr       AS INTEGER

    DIM iCounter AS INTEGER


' Check if empty decoded string.
' If Empty, return NUL and Generate error 254
    IF LEN(szUnEncoded) = 0 THEN
        ENCODE64$ = ""
        ERROR 254
        EXIT FUNCTION
    END IF

' Initialize lookup dictionary and constants
    szAlphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

    icBitShift = 4
    icChopMask = 255
    icLowFill = 3


' Initialize Masks
    szTemp = ""

    iHighMask = &HFC
    iLowMask = &H3
    iShift = &H10
    iRollOver = 0


' Begin Encoding process
    FOR iCounter = 1 TO LEN(szUnEncoded)

' Fetch ascii character in decoded string
        iChar = ASC(MID$(szUnEncoded, iCounter, 1))

' Calculate Alphabet lookup pointer
        iPtr = ((iChar AND iHighMask) \ (iLowMask + 1)) OR iRollOver

' Roll bit patterns
        iRollOver = (iChar AND iLowMask) * iShift

' Concatenate encoded character to working encoded string
        szTemp = szTemp + MID$(szAlphabet, iPtr + 1, 1)

' Adjust masks
        iHighMask = (iHighMask * icBitShift) AND icChopMask
        iLowMask = iLowMask * icBitShift + icLowFill
        iShift = iShift \ icBitShift

' If last character in block, concat last RollOver and
'   reset masks
        IF iHighMask = 0 THEN
            szTemp = szTemp + MID$(szAlphabet, iRollOver + 1, 1)
            iRollOver = 0
            iHighMask = &HFC
            iLowMask = &H3
            iShift = &H10
        END IF

    NEXT iCounter

' If RollOver remains, concat it to the working string
    IF iShift < &H10 THEN
        szTemp = szTemp + MID$(szAlphabet, iRollOver + 1, 1)
    END IF

' Pad encoded string with required '=' pad characters
    iPtr = (LEN(szTemp) MOD 4)
    IF iPtr THEN szTemp = szTemp + STRING$(4 - iPtr, "=")

' Return encoded string
    ENCODE64$ = szTemp
END FUNCTION

'----------------------------------------------------------------------------------------------
' Name:         INITDECODE64
' Type:         Sub procedure
' Description:  Initializes local shared variables for DECODE64$
'                   Required because many encoded files cannot be decoded in a single string
'
' Used:         Before decoding a BASE64 file.  (DECODE64$)
' Arguements:   None
' Returns:      Nothing
'
' Errors:       None
'
' Global Variables used:
'               szAlphabet             Encode/Decode Table lookup
'
'               icChopMask             Constant value in variable to speed process
'               icBitShift             Constant value in variable to speed process
'               icStartMask            Constant value in variable to speed process
'
'               iShift                 Multiplier shift value
'               iLowShift              Mask Low bits of each char
'               iRollOver              Decoded Roll over value from prev char in string
'               iHighMask              Mask high bits of each char
'----------------------------------------------------------------------------------------------
SUB InitDecode64

' Initialize 2nd encoding pass lookup dictionary
    szAlphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"

' Initialize Constants
    icChopMask = 255
    icBitShift = 4
    icStartMask = &H10

' Initialize Masks
    iShift = icBitShift
    iLowShift = 0
    iRollOver = 0
    iHighMask = -1
END SUB