Kontakt
DSVGO
Sub TestCompressPrinzip() Dim s As String Dim RLE() As Byte Dim Data() As Byte Dim i As Long 'String vorgeben: s = String$(5, "A") & String$(15, "B") Debug.Print s & " (" & Len(s) & " Zeichen)" 'String in Byte-Array konvertieren: Data = StrConv(s, vbFromUnicode) 'String als Bytes ausgeben: For i = 0 To UBound(Data) Debug.Print CStr(Data(i)); " "; Next i Debug.Print "(" & i & " Bytes)" 'Komprimierung: RLECompressPrinzip Data, RLE, 0 'Ergebnis ausgeben: For i = 0 To UBound(RLE) Debug.Print CStr(RLE(i)); " "; Next i Debug.Print "(" & i & " Bytes)" End SubDie folgenden Ergebnisse werden im Direktfenster ausgegeben:
AAAAABBBBBBBBBBBBBBB (20 Zeichen) 65 65 65 65 65 66 66... (insgesamt 15 mal) 66 (20 Bytes) 0 4 65 0 14 66 (6 Bytes)Das heisst also, dass der ursprüngliche String auf 6 Bytes komprimiert wurde. Man beachte, dass die gespeicherte Wiederholungs-Anzahl (hier fett dargestellt) immer um eins kleiner ausfällt, als eigentlich gedacht. Dies geschieht aus Einsparungsgründen: So steht "0" für eine Wiederholung, und "255" für 256 Wiederholungen.
Sub RLECompressPrinzip( _ ByRef Mem() As Byte, _ ByRef RLE() As Byte, _ ByVal TagValue As Byte _ ) Dim MemPos As Long Dim MemLen As Long Dim MemValue As Byte Dim RLEPos As Long Dim Anzahl As Long Dim i As Long 'Initialisierung: MemPos = LBound(Mem) MemLen = UBound(Mem) RLEPos = MemPos ReDim RLE(RLEPos To MemLen + 3) 'RLE-Codierung: Do While RLEPos < MemLen 'Anzahl gleicher Bytes bestimmen: MemValue = Mem(MemPos) i = MemPos + 255: If i > MemLen Then i = MemLen For i = MemPos + 1 To i If Mem(i) <> MemValue Then Exit For Next i Anzahl = i - MemPos MemPos = i 'RLE-Code für das Byte erzeugen: If Anzahl > 3 Or MemValue = TagValue Then 'Komprimieren: RLE(RLEPos) = TagValue RLE(RLEPos + 1) = Anzahl - 1 RLE(RLEPos + 2) = MemValue RLEPos = RLEPos + 3 Else 'Kopieren: For RLEPos = RLEPos To RLEPos + Anzahl - 1 RLE(RLEPos) = MemValue Next RLEPos End If If MemPos > MemLen Then Exit Do Loop 'Ergebnis formatieren: If RLEPos <= MemLen Then ReDim Preserve RLE(LBound(Mem) To RLEPos - 1) Else Erase RLE() End If End Sub
© Jost Schwider, 22.01.2001-22.01.2001 - http://vb-tec.de/rle2.htm