Author  

Language  

Operating Systems  

' Start a new project and add two command buttons to the form and aslo a text box
' Now place the follwing code below in to the general declarations selecion of the 
' form and press 5F. Press the Commpress button and see what has happend to the 
' string and then press the Uncompress and you see the string in it's normal size agian

' A bit of info on how this works
' Run Length Encodeing works by finding repeated chars in a string
' by finding a 3 byte code. the code consists of a flag character, a count byte, 
' and the repeated character. For instance, the string "ZZZZBBBBDDDD" would be 
' compressed as "ÿZÿ
Bÿ
D" or a simple form would be 4z4b4d. 
' RLE is also used in other forms such as for compressing JPEGS snd bitmaps
' any way I am not 100 % if what I said is right you would have to find out your
' own ideas on how it works

Function RLE_Compress(TString As String) As String
          
    Dim TChar1, TChar2, TChar3, TChar4, StrBuff, StrBuffer As String
    Dim RLE As Boolean
    Dim XPos As Integer
    Dim TLoop As Integer
          
    For TLoop = 1 To Len(TString)
        TChar1 = Mid(TString, TLoop, 1)
        TChar2 = Mid(TString, TLoop + 1, 1)
        TChar3 = Mid(TString, TLoop + 2, 1)
        XPos = 1
          
        If Not TChar1 = TChar2 Then RLE = False
        If TChar1 = TChar2 And TChar1 = TChar3 Then
            RLE = True
        End If
              
        If RLE = True Then
DoLoop:
                
            XPos = XPos + 1
            TChar4 = Mid(TString, TLoop + XPos, 1)
            If TChar4 = TChar1 Then GoTo DoLoop
            StrBuff = Chr(255) & Chr(XPos - 1) & TChar1
            TLoop = TLoop + XPos
        End If
                  
        If RLE = False Then StrBuff = TChar1
        StrBuffer = StrBuffer & StrBuff
    Next
        RLE_Compress = StrBuffer
                  
End Function
          
Function RLE_UNCompress(TString As String) As String
          
    Dim TChar1, TChar2, TChar3, TChar4 As Integer
    Dim StrBuff, StrBuffer As String
    On Error Resume Next
          
    Dim XPos As Integer
    Dim TLoop As Integer
          
    For TLoop = 1 To Len(TString)
        TChar1 = Asc(Mid(TString, TLoop, 1))
        TChar2 = Asc(Mid(TString, TLoop + 1, 1))
        TChar3 = Asc(Mid(TString, TLoop + 2, 1))
        TChar4 = Asc(Mid(TString, TLoop - 1, 1))
               
        If TChar1 = 255 Then
          
            For XPos = 1 To TChar2
                StrBuff = StrBuff & Chr(TChar3)
            Next
            TChar1 = ""
            TChar2 = ""
        End If
          
        If StrBuff = "" Then
          
            If Not TChar4 = 255 Then
                StrBuff = Chr(TChar1)
            End If
          
        End If
        StrBuffer = StrBuffer & StrBuff
        StrBuff = ""
    Next
                  
    RLE_UNCompress = StrBuffer
              
End Function

Private Sub Command1_Click()
    Text1.Text = RLE_Compress(Text1.Text)
    
End Sub

Private Sub Command2_Click()
    Text1.Text = RLE_UNCompress(Text1.Text)

End Sub

Private Sub Form_Load()
    Text1.Text = "aaaaaaaaaaaabbbbbbbbbbbccccccccccyyyyyyyyyyy"
    Command1.Caption = "Compress"
    Command2.Caption = "UnCompress"
    
End Sub