11-09-2025, 06:43 PM
This program converts your binary file (or text) to a Base85 string. You can then (with your own program) split it into individual lines for the DATA block and thus get any binary files into the source code.
Alternatives are: Base64 (https://qb64phoenix.com/forum/showthread...ght=base64)
Hex$ - each byte is written as a two-byte value into the DATA block.
Base85 has the smallest output string size of the three methods listed.
I use an image to test the speed of this program. Change its name on row 6 to the filename you are testing it on.
Alternatives are: Base64 (https://qb64phoenix.com/forum/showthread...ght=base64)
Hex$ - each byte is written as a two-byte value into the DATA block.
Base85 has the smallest output string size of the three methods listed.
I use an image to test the speed of this program. Change its name on row 6 to the filename you are testing it on.
Code: (Select All)
'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
