Function RLEEncode(ByVal EncodeText As String) As String
'Benötigte Variablen
Dim Pos As Long, ZielText As String, WieLang As Long, LastChar As String
'Zeichen abklappern
For Pos = 1 To Len(EncodeText)
    'Wenns ein anderes ist...
    If Mid(EncodeText, Pos, 1) <> LastChar Then
        'Falls noch kein Text vorhanden, neu beginnen
        If LastChar = vbNullString Then
            'Wie oft war es da? Genau 1 mal, nämlich jetzt
            WieLang = 1
            'Und welches Zeichen?
            LastChar = Mid(EncodeText, Pos, 1)
        Else
            'Zuweisen an den Rückgabewert
            ZielText = ZielText & Chr(WieLang) & LastChar
            'Die Länge des neuen Textes ist 1
            WieLang = 1
            'Welches Zeichen ist aktuell?
            LastChar = Mid(EncodeText, Pos, 1)
        End If
    'Wenn es das gleiche ist...
    Else
        '...Zähler erhöhen
        WieLang = WieLang + 1
        'Falls die Länge > 255 wird, muss es als anderes
        'Zeichen gewertet werden. Sonst ist ein Überlauf
        'die Folge...
        If WieLang = 255 Then
            'Zum Zieltext hinzufügen
            ZielText = ZielText & Chr(WieLang) & LastChar
            'Variable auf 1
            WieLang = 1
            'Nullstring zuweisen
            LastChar = vbNullString
        End If
    End If
Next Pos
'Nun ja, das letzte Zeichen muss auch noch hinzugefügt werden.
'Zuerst prüfen, ob vorhanden...
If LastChar <> vbNullString Then
    'Zuweisen an den Rückgabewert
    ZielText = ZielText & Chr(WieLang) & LastChar
End If
'Falls kein Text im Rückgabewert, war wahrscheinlich nur eine
'Buchstabengruppe im Einsatz, z. B. Space(10)
If ZielText = vbNullString Then
    'Buchstaben zuweisen
    ZielText = Chr(Len(ZielText)) & String(Len(ZielText), _
        Left(EncodeText, 1))
End If
'Rückgabewert zuweisen
RLEEncode = ZielText
End Function
 
Function RLEDecode(ByVal DecodeText As String) As String
'Die Variablen deklariern
Dim Pos As Long, ZielText As String, _
    LenC As Long, WasC As String * 1
'Wieder abklappern, aber alle 2 Zeichen
For Pos = 1 To Len(DecodeText) Step 2
    'Die Länge...
    LenC = Asc(Mid(DecodeText, Pos, 1))
    '... und das Zeichen ermitteln
    WasC = Mid(DecodeText, Pos + 1, 1)
    'Dem Zieltext zuweisen...
    ZielText = ZielText & String(LenC, WasC)
Next Pos
'...und den Zieltext als Rückgabewert ausgeben
RLEDecode = ZielText
End Function

???????????????????????????????????????????????????????????
e7o.de | jetzt (wirklich) neu!