Keskustelu: Koodit: VB6: RLE pakkaus

Sub Compress(DataIn As String, DataOut As String)

    Dim CharCount As Integer
    Dim NewChar As Integer
    Dim LastChar As Integer
    Dim CharLoop As Integer
    Dim CharPtr As Long
    Dim CharStrLen As Long
    Dim Compressed As String
    Dim MgrChar As Byte

    CharCount = -1
    CharStrLen = Len(DataIn)

    '+1 että vois kattoo kanssa viimisen erkki merkin
    For CharPtr = 1 To CharStrLen + 1
        'jos ei vika looppi, otetaan newchariin uus charakteri.
        'muuten  -1 meinaa että viiminen looooooooooooop
        If CharPtr < CharStrLen + 1 Then
            NewChar = Asc(Mid(DataIn, CharPtr, 1))
        Else
            NewChar = -1
        End If

        'yks siihen yhteensä laskuriin
        CharCount = CharCount + 1
        If CharPtr > 1 Then
            'sama merkki kun viimeks?
            If NewChar = LastChar Then
                'onks merkkejä niin paljon että yks manageri ei pysty
                'kertomaan enempää
                If CharCount = 128 Then
                    'jos on, niin se characteri saa "manageri tavun"
                    'laitetaa countti n0llaks(countteri aina yhen vähemmän kuin
                    'mitä merkkejä on)
                    MgrChar = 128
                    MgrChar = MgrChar Or 127
                    Compressed = Compressed & Chr(MgrChar) & Chr(LastChar)
                    'merkki laskuri nollaks
                    CharCount = 0
                End If
            Else
                'täll kertaa eri merkki elikkä katotaan onks enemmän kuin kaksi
                If CharCount > 2 Then
                    'enemmän kui kaksi elikkä manageria mukaan
                    MgrChar = 128
                    MgrChar = MgrChar Or (CharCount - 1)
                    'manageri ja merkki siihen ulostuloon
                    Compressed = Compressed & Chr(MgrChar) & Chr(LastChar)
                Else
                    'kaksi samaa muttei tarpeeks että käytettäs pakkausta turhaan
                    'koska siihenkin menee kaksi tavua

                    'pistä merkit outputtiin
                    For CharLoop = 1 To CharCount
                        'onks bittei enemmän kun arvon 127 muuten voitas sekottaa
                        'erikoismerkki manageriin
                        If LastChar > 127 Then
                            outchar = 128
                            outchar = outchar Or (CharCount - 1)
                            Compressed = Compressed & Chr(MgrChar) & Chr(LastChar)
                        Else
                            'ei oo liian iso merkki joten normaalisti mukaan
                            Compressed = Compressed & Chr(LastChar)
                        End If
                    Next CharLoop
                End If
                'resetataan charricountti
                CharCount = 0
            End If
        End If
        'viimeks luettu on uus tästä lähin että ihmetarkistus toimis ens kerralla
        LastChar = NewChar
    Next CharPtr
    DataOut = Compressed 'valmista! Huhhuh.

End Sub

Sub UnCompress(DataIn As String, DataOut As String)

    Dim NewChar As Byte
    Dim CharCount As Integer
    Dim CharPtr As Long
    Dim UnCompressed As String
    CharPtr = 0
    Do
        'yks lisää
        CharPtr = CharPtr + 1
        NewChar = Asc(Mid(DataIn, CharPtr, 1))
        'monta merkkiä pakattuna?
        If NewChar > 127 Then
            'oke manageri löytyi...

            'montaks pakattua merkkiä?
            CharCount = (NewChar And 127) + 1
            'seuraava
            CharPtr = CharPtr + 1
            NewChar = Asc(Mid(DataIn, CharPtr, 1))
            'puretaan pakkaus
            UnCompressed = UnCompressed & String(CharCount, NewChar)
        Else
            'vaan yks merkki, pyh...
            UnCompressed = UnCompressed & Chr(NewChar)
        End If
    'katellaan kunnes vika merkki
    Loop Until (CharPtr >= Len(DataIn))

    'valmista
    DataOut = UnCompressed

End Sub