Run Length Encoding Example
Probably the simplest of compression methods, run length encoding might be useful in helping you store large amounts of repetitive data.
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 again.
A bit of info on how this works: Run Length Encodeing works by finding repeated chars in a stringby 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.
Module
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
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
Special Instructions
This code originally appeared on AndreaVB.com, and has been republished here with the permission of Andrea Tincani.
Loading Comments ...
Comments
No comments have been added for this post.
You must be logged in to make a comment.