[vb6] Base85 Encoding/Decoding
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
Code:
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]
Re: [vb6] Base85 Encoding/Decoding
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:
Code:
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
Re: [vb6] Base85 Encoding/Decoding
Quote:
Originally Posted by
VBClassicRocks
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
Re: [vb6] Base85 Encoding/Decoding
