'Baze85 is option to save your binary files directly to your source code as DATA block.

'Output string is smaller than Base64 string.



Dim As Long FileSize

ff = FreeFile

f$ = "6.jpg"

Open f$ For Binary As ff

FileSize = LOF(ff)

text$ = Space$(FileSize)

Get ff, , text$

Close ff







code$ = Base85Encode(text$)

codeout$ = Base85Decode$(code$)





Print "Image coded to base85. Base85 string lenght:"; Len(code$); " Original source file size:"; FileSize; "Press any key to show output string..."

Sleep

Print code$

Print

Print "Press any key for decoding back to binary form and loading image from it."

Sleep



img = _LoadImage(codeout$, 32, "memory")

Screen img















Function Base85Encode$ (binData As String)



    Dim As Long totalLen, fullBlocks, remBytes

    Dim As Long i, srcPos, outtPos

    Dim As _Unsigned Long n

    Dim As String outt, chunk



    totalLen = Len(binData)

    fullBlocks = totalLen \ 4

    remBytes = totalLen Mod 4



    ' Předpočítaná délka výstupu (bez zkratky 'z'):

    ' <~ + fullBlocks*5 + (remBytes>0 ? remBytes+1 : 0) + ~>

    Dim As Long outtLen

    outtLen = 2 + fullBlocks * 5

    If remBytes > 0 Then outtLen = outtLen + (remBytes + 1)

    outtLen = outtLen + 2



    outt$ = Space$(outtLen)

    Mid$(outt$, 1, 2) = "<~"

    outtPos = 3



    ' Plné bloky po 4 bajtech

    For i = 0 To fullBlocks - 1

        srcPos = i * 4 + 1



        n = (Asc(binData, srcPos)) * 16777216~&& _

          + (Asc(binData, srcPos + 1)) * 65536~&& _

          + (Asc(binData, srcPos + 2)) * 256~&& _

          + (Asc(binData, srcPos + 3))



        ' rozklad na 5 číslic v základu 85 (big-endian)

        Dim d0 As _Unsigned Long, d1 As _Unsigned Long, d2 As _Unsigned Long, d3 As _Unsigned Long, d4 As _Unsigned Long

        d4 = n Mod 85: n = n \ 85

        d3 = n Mod 85: n = n \ 85

        d2 = n Mod 85: n = n \ 85

        d1 = n Mod 85: n = n \ 85

        d0 = n ' poslední



        Mid$(outt$, outtPos, 1) = Chr$(33 + d0)

        Mid$(outt$, outtPos + 1, 1) = Chr$(33 + d1)

        Mid$(outt$, outtPos + 2, 1) = Chr$(33 + d2)

        Mid$(outt$, outtPos + 3, 1) = Chr$(33 + d3)

        Mid$(outt$, outtPos + 4, 1) = Chr$(33 + d4)

        outtPos = outtPos + 5

    Next



    ' Zbývající 1..3 bajty

    If remBytes > 0 Then

        srcPos = fullBlocks * 4 + 1

        n = 0

        If remBytes >= 1 Then n = n + (Asc(binData, srcPos)) * 16777216~&&

        If remBytes >= 2 Then n = n + (Asc(binData, srcPos + 1)) * 65536~&&

        If remBytes >= 3 Then n = n + (Asc(binData, srcPos + 2)) * 256~&&



        ' Převod na 5 znaků a vezmeme prvních remBytes+1

        Dim e0 As _Unsigned Long, e1 As _Unsigned Long, e2 As _Unsigned Long, e3 As _Unsigned Long, e4 As _Unsigned Long

        e4 = n Mod 85: n = n \ 85

        e3 = n Mod 85: n = n \ 85

        e2 = n Mod 85: n = n \ 85

        e1 = n Mod 85: n = n \ 85

        e0 = n



        ' kolik znaků vytisknoutt

        Dim As Long emit

        emit = remBytes + 1



        Mid$(outt$, outtPos, 1) = Chr$(33 + e0)

        If emit >= 2 Then Mid$(outt$, outtPos + 1, 1) = Chr$(33 + e1)

        If emit >= 3 Then Mid$(outt$, outtPos + 2, 1) = Chr$(33 + e2)

        If emit >= 4 Then Mid$(outt$, outtPos + 3, 1) = Chr$(33 + e3)

        outtPos = outtPos + emit

    End If



    Mid$(outt$, outtPos, 1) = "~"

    Mid$(outt$, outtPos + 1, 1) = ">"

    Base85Encode$ = outt$

End Function



' ----------------------- DECODE -----------------------

Function Base85Decode$ (base85Data As String)

    Dim As Long L, i, outtLen, outtPos

    Dim As String s, outt



    ' Najdi první výskyt "~>" a všechno za ním odstraň

    Dim As Long endPos

    endPos = InStr(base85Data, "~>")

    If endPos > 0 Then base85Data = Left$(base85Data, endPos + 1)



    L = Len(base85Data)

    If L >= 4 Then

        ' Ořízni obal <~ a ~>

        If Left$(base85Data, 2) = "<~" And Right$(base85Data, 2) = "~>" Then

            s$ = Mid$(base85Data, 3, L - 4)

        Else

            s$ = base85Data

        End If

    Else

        s$ = base85Data

    End If



    ' Odstranit bílé znaky a spočítat odhad výstupní délky

    Dim As String cleaned

    cleaned$ = Space$(Len(s$))

    Dim As Long clen: clen = 0

    outtLen = 0



    For i = 1 To Len(s$)

        Dim ch As Integer

        ch = Asc(s$, i)

        If ch = 32 Or ch = 9 Or ch = 13 Or ch = 10 Then

            ' přeskoč whitespace

        ElseIf ch = Asc("z") Then

            clen = clen + 1: Mid$(cleaned$, clen, 1) = "z"

            outtLen = outtLen + 4

        Else

            clen = clen + 1: Mid$(cleaned$, clen, 1) = Chr$(ch)

        End If

    Next

    If clen > 0 Then cleaned$ = Left$(cleaned$, clen) Else cleaned$ = ""



    ' dopočítej délku výstupu (každých 5 znaků -> 4 bajty)

    Dim As Long normChars, full, rest

    For i = 1 To clen

        If Mid$(cleaned$, i, 1) <> "z" Then normChars = normChars + 1

    Next

    full = normChars \ 5

    rest = normChars Mod 5

    outtLen = outtLen + full * 4

    If rest >= 2 Then outtLen = outtLen + (rest - 1)



    outt$ = Space$(outtLen)

    outtPos = 1



    ' Dekódování

    Dim As Long accCount

    Dim As _Integer64 acc

    acc = 0: accCount = 0



    For i = 1 To clen

        Dim c$: c$ = Mid$(cleaned$, i, 1)

        If c$ = "z" Then

            acc = 0: accCount = 0

            Mid$(outt$, outtPos, 4) = String$(4, Chr$(0))

            outtPos = outtPos + 4

        Else

            Dim v As Long

            v = Asc(c$) - 33

            If v >= 0 And v <= 84 Then

                acc = acc * 85 + v

                accCount = accCount + 1

                If accCount = 5 Then

                    Dim As _Integer64 t: t = acc

                    Dim b1 As Long, b2 As Long, b3 As Long, b4 As Long

                    b4 = t Mod 256: t = t \ 256

                    b3 = t Mod 256: t = t \ 256

                    b2 = t Mod 256: t = t \ 256

                    b1 = t

                    Mid$(outt$, outtPos, 1) = Chr$(b1)

                    Mid$(outt$, outtPos + 1, 1) = Chr$(b2)

                    Mid$(outt$, outtPos + 2, 1) = Chr$(b3)

                    Mid$(outt$, outtPos + 3, 1) = Chr$(b4)

                    outtPos = outtPos + 4

                    acc = 0: accCount = 0

                End If

            End If

        End If

    Next



    ' Opravené zpracování posledního zkráceného bloku

    If accCount >= 2 And accCount <= 4 Then

        ' Doplň chybějící znaky jako 'u' (hodnota 84)

        Dim j As Long

        For j = accCount + 1 To 5

            acc = acc * 85 + 84

        Next





        t = acc



        b4 = t Mod 256: t = t \ 256

        b3 = t Mod 256: t = t \ 256

        b2 = t Mod 256: t = t \ 256

        b1 = t



        Dim As Long need

        need = accCount - 1

        If need >= 1 Then Mid$(outt$, outtPos, 1) = Chr$(b1)

        If need >= 2 Then Mid$(outt$, outtPos + 1, 1) = Chr$(b2)

        If need >= 3 Then Mid$(outt$, outtPos + 2, 1) = Chr$(b3)

        ' >>> DŮLEŽITÉ: posuň ukazatel výstupu <<<

        outtPos = outtPos + need

    End If



    ' Ořízni případné nevyužité bajty

    If outtPos > 1 Then

        Base85Decode$ = Left$(outt$, outtPos - 1)

    Else

        Base85Decode$ = ""

    End If

End Function