Binaryworld - Run Length Encodeing Compression example ... [ VB -> Files & Folder ]

Module

' 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

Usage

Click here to copy the following block

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