' RLEPack by ULTRAS [MATRiX]
' Simple RLE Compress/Decompress algorithm.

Private Sub Exemple()
' RLEPack by ULTRAS[MATRiX]
Dim algarr() As Byte
Dim ustring As String, comps As String
ustring = "MMMMMMAAAAAATTTTTTRRRRRRRRIIIIIIIIXXXXXXXX4EEEVVVERRR"
RLECompress ustring, algarr
comps = algarr
MsgBox "Original string: " + ustring + vbCrLf + _
"Original string length:" + Str$(Len(ustring)) + vbCrLf + _
"Compressed string: " + comps + vbCrLf + _
"Compressed length:" + Str$(Len(comps)) + vbCrLf + _
"Decompressed string: " + RLEDecompress(algarr)
End Sub

Public Sub RLECompress(stringtocomp As String, ByteArr() As Byte)
Dim algarr() As Byte
Dim u As Integer
Dim bytec As Byte
Dim prevadd As Boolean
algarr = StrConv(stringtocomp, vbFromUnicode)
ReDim ByteArr(0)
ByteArr(0) = algarr(0)
For u = 1 To UBound(algarr)
If algarr(u) = algarr(u - 1) Then
bytec = u
Do Until (algarr(bytec) <> algarr(u - 1)) Or (bytec - (u - 1) = 254)
bytec = bytec + 1
If bytec > UBound(algarr) Then Exit Do
Loop
If UBound(ByteArr) = 0 Then
ReDim Preserve ByteArr(UBound(ByteArr) + 1)
ElseIf prevadd = False Then
ReDim Preserve ByteArr(UBound(ByteArr) + 2)
End If
ByteArr(UBound(ByteArr) - 1) = (bytec - (u - 1))
ByteArr(UBound(ByteArr)) = algarr(u)
u = bytec - 1
prevadd = False
Else
ReDim Preserve ByteArr(UBound(ByteArr) + 2)
ByteArr(UBound(ByteArr) - 1) = 1
ByteArr(UBound(ByteArr)) = algarr(u)
prevadd = True
End If
Next u
End Sub

Public Function RLEDecompress(ByteArr() As Byte)
Dim u As Integer
For u = 0 To UBound(ByteArr) Step 2
RLEDecompress = RLEDecompress & String(ByteArr(u), Chr(ByteArr(u + 1)))
Next u
End Function
