[vb6] Base85 Encoding/Decoding

[LaVolpe]

I came upon a need for Base85 decryption. This encryption/decryption is much like Base64 in principle and purpose. I could not find any existing routines, in VB6, that actually worked with binary data, so I created my own.

Feel free to use & abuse. If you find an error, please post it. The code can be added to a module or class

I've tested the results by encoding/decoding 100's of files and confirmed encryption against this web site:
http://www.webutils.pl/index.php?idx=ascii85

Option Explicit

' Purpose: Encode/Decode BASE85 ASCII
' http://en.wikipedia.org/wiki/Ascii85

' routines convert source string/array to encoded array
' also convert encoded string/array to unencoded array

' should you need a String vs. Array returned,
' use StrConv() on the returned array:
'   myString = StrConv(arrayResult(), vbUnicode)

Private Type SafeArrayBound          ' OLE structure
    cElements As Long
    lLbound As Long
End Type
Private Type SafeArray
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    rgSABound(0 To 1) As SafeArrayBound ' reusable UDT for 1 & 2 dim arrays
End Type

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal length As Long)
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef ptr() As Any) As Long

Public Function EncodeBase85_FromStringToArray(ByVal sourceData As String, outArray() As Byte, Optional Add_bota_Header As Boolean = False) As Boolean

    ' convert string source to BASE85 encoded array

    Dim tSA As SafeArray, tData() As Byte
    
    If sourceData = "" Then
        If Add_bota_Header Then
            outArray = StrConv("<~~>", vbFromUnicode)
        Else
            outArray = StrConv("~>", vbFromUnicode)
        End If
        EncodeBase85_FromStringToArray = True
    Else
        With tSA                    ' overlay array on passed string data
            .cbElements = 1
            .cDims = 1
            .pvData = StrPtr(sourceData)
            .rgSABound(0).cElements = Len(sourceData) * 2&
        End With
        CopyMemory ByVal VarPtrArray(tData), VarPtr(tSA), 4&
        On Error Resume Next
        EncodeBase85_FromStringToArray = zEncodeArray(tData(), outArray(), Add_bota_Header, 2)
        CopyMemory ByVal VarPtrArray(tData), 0&, 4&
    End If
    
End Function

Public Function EncodeBase85_FromArrayToArray(sourceData() As Byte, outArray() As Byte, Optional Add_bota_Header As Boolean = True) As Boolean

    ' convert array source to BASE85 encoded array

    On Error Resume Next
    EncodeBase85_FromArrayToArray = zEncodeArray(sourceData(), outArray(), Add_bota_Header, 1)

End Function

Public Function DecodeBase85_FromArrayToArray(sourceData() As Byte, outArray() As Byte) As Boolean

    ' unencode BASE85 source array to original data

    On Error Resume Next
    DecodeBase85_FromArrayToArray = zDecodeArray(sourceData(), outArray(), 1)

End Function

Public Function DecodeBase85_FromStringToArray(sourceData As String, outArray() As Byte) As Boolean

    ' unencode BASE85 source string to original data

    On Error GoTo EH
    Dim tSA As SafeArray, theData() As Byte
    
    If sourceData = "" Then Exit Function
    
    With tSA                            ' overlay array on passed string data
        .cbElements = 1
        .cDims = 1
        .pvData = StrPtr(sourceData)
        .rgSABound(0).cElements = Len(sourceData) * 2&
    End With
    CopyMemory ByVal VarPtrArray(theData), VarPtr(tSA), 4&
    On Error Resume Next
    DecodeBase85_FromStringToArray = zDecodeArray(theData(), outArray(), 2)
    CopyMemory ByVal VarPtrArray(theData), 0&, 4&
    
EH:
End Function

Private Function zDecodeArray(theData() As Byte, outData() As Byte, incrValue As Long) As Boolean

    ' decode properly encoded Base85 ASCII

    Dim c As Long, ub As Long, srcPtr As Long, dstPtr As Long
    Dim lValue As Long, lCount As Long, dblValue As Double
    
    If theData(0) = 60 Then                     ' test for bota header of: <~
        If theData(incrValue) = 126 Then srcPtr = 2& * incrValue Else Exit Function
    End If
    
    On Error GoTo EH
    
    ' first scan array ensuring format & sizing end result
    For c = srcPtr To UBound(theData) Step incrValue
        Select Case theData(c)
        Case 33 To 117        ' expected !-u
            lCount = lCount + 1&
        Case 122            ' expected z
            If (lCount Mod 5&) Then Exit Function ' corrupted Base85 or not Base85 after all
            ' letter z cannot occur between 5 character tuple
            lCount = lCount + 5&
        Case 126            ' bota footer: ~>
            If theData(c + incrValue) = 62 Then ' >
                ub = c - incrValue
                Exit For
            Else
                Exit Function                   ' corrupted Base85 or not Base85 afterall
            End If
        Case Is > 117                           ' corrupted Base85 or not Base85 afterall
            Exit Function
        Case Else
            ' treat as white space
        End Select
    Next
    If ub = 0& Then Exit Function    ' footer not found
    
    ' size end result; calculate partial "words"
    c = lCount Mod 5&
    If c Then
        lCount = ((lCount - c) \ 5&) * 4& + c - 1&
    Else
        lCount = (lCount \ 5&) * 4&
    End If
    ReDim outData(0 To lCount - 1&)
    
    lCount = 4&                                 ' character countdown
    For srcPtr = srcPtr To ub Step incrValue
        Select Case theData(srcPtr)
        Case 33 To 117                          ' !-u
            ' double being used to allow unsigned values > 2147483647
            dblValue = dblValue * 85# + theData(srcPtr) - 33#
            If lCount = 0& Then
                If dblValue > 2147483647# Then
                    lValue = dblValue - 4294967296# ' convert unsigned to signed
                Else
                    lValue = dblValue
                End If
                ' convert big to little endian
                outData(dstPtr + 3&) = lValue And &HFF
                outData(dstPtr + 2&) = (lValue And &HFF00&) \ &H100&
                outData(dstPtr + 1&) = (lValue And &HFF0000) \ &H10000
                If lValue < 0& Then
                    outData(dstPtr) = (lValue And &H7F000000) \ &H1000000 Or &H80
                Else
                    outData(dstPtr) = (lValue And &HFF000000) \ &H1000000
                End If
                dstPtr = dstPtr + 4&            ' move pointer along
                lCount = 4&: dblValue = 0#      ' reset these
            Else
                lCount = lCount - 1&
            End If
        Case 122                                ' z = all zeroes
            dstPtr = dstPtr + 4&                ' move pointer along (dblValue will always be zero)
        Case Else
        End Select
    Next
    
    If dstPtr <= UBound(outData) Then           ' handle partial "words"
        ub = UBound(outData)
        For lCount = lCount To 0& Step -1&      ' finish buffering with max value of 84
            dblValue = dblValue * 85# + 84#
        Next
        If dblValue > 2147483647# Then          ' convert unsigned to signed as needed
            lValue = dblValue - 4294967296#
        Else
            lValue = dblValue
        End If
        If lValue < 0& Then                     ' populate the destination array as needed
            outData(dstPtr) = (lValue And &H7F000000) \ &H1000000 Or &H80
        Else
            outData(dstPtr) = (lValue And &HFF000000) \ &H1000000
        End If
        If dstPtr + 1& <= ub Then
            outData(dstPtr + 1&) = (lValue And &HFF0000) \ &H10000
            If dstPtr + 2& <= ub Then outData(dstPtr + 2&) = (lValue And &HFF00&) \ &H100&
        End If
    End If
    zDecodeArray = True                         ' done

EH:
    If Err Then Err.Clear
End Function

Private Function zEncodeArray(theData() As Byte, outArray() As Byte, Add_bota_Header As Boolean, incrValue As Long) As Boolean

    Dim c As Long, ub As Long
    Dim dstPtr As Long, lValue As Long
    Const CHARSPERLINE As Long = 73&
    
    On Error GoTo EH
    ub = UBound(theData) + 1&
    
    ' standard Base85 uses the bota header of <~ and footer of ~>
    ' however, Adobe PDF files, for example, do not use the header but do use the footer
    
    ' size return string (may be shorter when done) & set start position for encoding
    If Add_bota_Header Then dstPtr = 2&
    lValue = ((ub \ incrValue) \ 4&) * 5& + 5&
    ReDim outArray(0 To (lValue + dstPtr + 5& + (lValue \ CHARSPERLINE ) * 2&))
    If Add_bota_Header Then
        outArray(0) = 60: outArray(1) = 126     ' <~
    End If

    For c = 0 To ub - 4& * incrValue Step 4& * incrValue
        ' create long value in big endian (opposite of what VB uses)
        If theData(c) > 127 Then                ' high bit set?
            lValue = (theData(c) - 128&) * &H1000000 Or &H80000000
        Else
            lValue = theData(c) * &H1000000
        End If                                  ' finish the value
        lValue = lValue Or theData(c + 1& * incrValue) * &H10000 Or theData(c + 2& * incrValue) * &H100& Or theData(c + 3& * incrValue)
        ' encode this long value & return new dstPtr
        Call zEncodeLong(lValue, outArray(), dstPtr, False)
    Next
    If c < ub Then                              ' finish off any remaining characters (3 or less)
        If theData(c) > 127 Then
            lValue = (theData(c) - 128) * &H1000000 Or &H80000000
        Else
            lValue = theData(c) * &H1000000
        End If
        ' finish building the long value preventing array bounds errors
        If c + 1& * incrValue < ub Then
            lValue = lValue Or theData(c + 1& * incrValue) * &H10000
            If c + 2& * incrValue < ub Then
                lValue = lValue Or theData(c + 2& * incrValue) * &H100&
                If c + 3& * incrValue < ub Then lValue = lValue Or theData(c + 3& * incrValue)
            End If
        End If
        ' encode this final long value
        Call zEncodeLong(lValue, outArray(), dstPtr, True)
        ' remove any padding created due to the non-4-character 'word'
        dstPtr = dstPtr - (4& - ((ub - c) \ incrValue))
    End If
    
    c = CHARSPERLINE                            ' formatting at n chars per line
    Do While c < dstPtr
        'Debug.Print c + 2 + (dstPtr - c + 1&); UBound(outArray) + 1
        CopyMemory outArray(c + 2&), outArray(c), dstPtr - c + 1&
        outArray(c) = 13: outArray(c + 1&) = 10
        dstPtr = dstPtr + 2&
        c = c + CHARSPERLINE + 2&
    Loop
    
    ' add the bota footer & return the result
    outArray(dstPtr) = 126: outArray(dstPtr + 1&) = 62
    ReDim Preserve outArray(0 To dstPtr + 1&)
    zEncodeArray = True

EH:
    If Err Then Err.Clear
End Function

Private Sub zEncodeLong(lngValue As Long, outData() As Byte, outPointer As Long, finalRun As Boolean)

    ' actual Base85 encoding routine.
    ' in: 4 byte long, out: 1 or 5 byte ASCII string
    
    Dim dblValue As Double, c As Long

    If lngValue = 0& And finalRun = False Then
        ' special case. 4 consecutive zero values are written as "z"
        outData(outPointer) = 122
        outPointer = outPointer + 1&
    
    Else
        ' 4 bytes to 5, write: lngValue Mod 85, adding value of 33 to form readable ASCII
        ' then shift lngValue down 85
    
        If lngValue < 0& Then   ' high bit set; need to ref lngValue as UINT, not signed
                
            ' get the high byte & convert signed long to unsigned double
            c = ((lngValue And &H7FFFFFFF) \ &H1000000) Or &H80
            dblValue = 16777216# * c + (lngValue And &HFFFFFF)
            
            If c < 170& Then
                lngValue = ((lngValue And &HFFFFFF) + ((c - 85&) * &H1000000)) \ 85& + (&H55000000 \ 85&)
            Else
                lngValue = ((lngValue And &HFFFFFF) + ((c - 170&) * &H1000000)) \ 85& + (&HAA0000 \ 85&) * &H100&
            End If
            c = dblValue - Int(dblValue / 85#) * 85# ' equivalent to: dblValue Mod 85 but without overflow error
            outData(outPointer + 4&) = c + 33&
            
        Else
            outData(outPointer + 4&) = (lngValue Mod 85&) + 33&
            lngValue = lngValue \ 85&
        End If
        
        For c = outPointer + 3& To outPointer Step -1&
            outData(c) = (lngValue Mod 85&) + 33&
            lngValue = lngValue \ 85&
        Next
        outPointer = outPointer + 5&
    End If

End Sub

Edited: If you are encoding very large arrays/strings, the routine that delimits the returned data to 73 characters per line can be time consuming. You may wish to remove that option. Here are three ways, each are located in the zEncodeArray function

1) Change From: Const CHARSPERLINE As Long = 73&
Change To: Const CHARSPERLINE As Long = &H7FFFFFFF
Above prevents delimiting if result is less than 2+ GB characters

2) Rem-out the final DO:Loop in that function, which is the code that delimits the return result

3) Add optional parameter to functions to pass a line length value, maybe defaulted to 73. Then in the zEncodeArray where you'd also include that parameter, line prior to the final Do:Loop:
Change From: c = CHARSPERLINE
Change To: c = [passedParameter]

[VBClassicRocks]

Many thanks for sharing. Looks like it would be ideal for password encryption/decryption.
Adding to your fine work, here's a few more functions that are just wrappers:

Public Function EncodeBase85_FromStringToString(ByVal sourceData As String, Optional Add_bota_Header As Boolean = False) As String
 Dim B() As Byte
 EncodeBase85_FromStringToArray sourceData, B, Add_bota_Header
 EncodeBase85_FromStringToString = StrConv(B, vbUnicode)
End Function
Public Function EncodeBase85_FromArrayToString(sourceData() As Byte, Optional Add_bota_Header As Boolean = True) As String
 Dim B() As Byte
 EncodeBase85_FromArrayToArray sourceData, B, Add_bota_Header
 EncodeBase85_FromArrayToString = StrConv(B, vbUnicode)
End Function
Public Function DecodeBase85_FromArrayToString(sourceData() As Byte) As String
 Dim B() As Byte
 DecodeBase85_FromArrayToArray sourceData, B
 DecodeBase85_FromArrayToString = StrConv(B, vbUnicode)
End Function
Public Function DecodeBase85_FromStringToString(sourceData As String) As String
 Dim B() As Byte
 DecodeBase85_FromStringToArray sourceData, B
 DecodeBase85_FromStringToString = StrConv(B, vbUnicode)
End Function

[LaVolpe]

Looks like it would be ideal for password encryption/decryption.

I wouldn't use it for passwords. Base85 & Base64 are methods that simply convert binary data to ASCII characters for transmission over the net or storage of binary data in text-type documents. Anyone that can recognize the format as Base85 or Base64 can easily decipher it. Both Base85 & Base64 have a very specific subset of ASCII characters, so both are easily recognized I would think

[VBClassicRocks]

OK, good info.