Kontakt
DSVGO
Sub TestUncompressPrinzip() Dim s1 As String Dim Data1() As Byte Dim RLE() As Byte Dim Data2() As Byte Dim s2 As String 'Test-String: s1 = String$(5, "A") & String$(15, "B") 'Komprimieren: Data1 = StrConv(s1, vbFromUnicode) RLECompressPrinzip Data1, RLE, 0 'Dekomprimieren: RLEUncompressPrinzip RLE, Data2, 0 s2 = StrConv(Data2, vbUnicode) 'Vergleichen: If s1 = s2 Then MsgBox "Alles OK" Else MsgBox "Fehler" End If End SubDas Beispiel sollte "Alles OK" ausgeben, ansonsten funktioniert eine der beiden Routinen nicht korrekt.
Public Sub RLEUncompressPrinzip( _ ByRef RLE() As Byte, _ ByRef Data() As Byte, _ ByVal TagValue As Byte _ ) Dim RLEPos As Long Dim RLEValue As Byte Dim DataPos As Long Dim DataUBound As Long Dim Anzahl As Long 'Initialisierung: RLEPos = LBound(RLE) Anzahl = UBound(RLE) - RLEPos + 1 DataUBound = Anzahl * 2 ReDim Data(DataUBound) 'RLE-Decodierung: Do Until RLEPos > UBound(RLE) RLEValue = RLE(RLEPos) If RLEValue = TagValue Then 'Parameter für Dekomprimierung: Anzahl = RLE(RLEPos + 1) RLEValue = RLE(RLEPos + 2) RLEPos = RLEPos + 3 'Ggf. Buffer vergrößern: If DataPos + Anzahl > DataUBound Then DataUBound = 2 * (DataPos + Anzahl) ReDim Preserve Data(DataUBound) End If 'Wiederholungen schreiben: For DataPos = DataPos To DataPos + Anzahl Data(DataPos) = RLEValue Next DataPos Else 'Ggf. Buffer vergrößern: If DataPos > DataUBound Then DataUBound = 2 * (DataPos + Anzahl) ReDim Preserve Data(DataUBound) End If 'Kopieren: RLEPos = RLEPos + 1 Data(DataPos) = RLEValue DataPos = DataPos + 1 End If Loop 'Ergebnis formatieren: ReDim Preserve Data(DataPos - 1) End Sub
© Jost Schwider, 25.01.2001-25.01.2001 - http://vb-tec.de/rle3.htm