String compression

This example shows you how to compress a string. The MaxPatternLen parameter of the Compress function basically controls the compression quality(the larger the value the better quality). The amount of time this adds far out ways how much more the string will be compressed. With that in mind you should usually leave the value at 5.

Private Type Pattern
    Text As String
    TimesRepeated As Integer
    Position As Long
End Type

Private Function Compress(Text As String, Optional ByVal MaxPatternLen As Byte = 5) Dim Patterns() As Pattern Dim PatternLen As Long Dim Char As String Dim Compressed As Integer Dim ShortestPattern As Byte

    If MaxPatternLen > Len(Text) Then MaxPatternLen = Len(Text) 'this can save alot of time
    ShortestPattern = 4 + Len(Str(Len(Text)))
    If ShortestPattern > MaxPatternLen Then ShortestPattern = MaxPatternLen

    ReDim Patterns(1 To 1)
    Do Until Text = ""
PatternLoop:
        If Text = "" Then Exit Do 'Sometimes control is directed here when it shouldn't be.
        For CurPatternLen = 1 To MaxPatternLen
            If MaxPatternLen > Len(Text) Then MaxPatternLen = Len(Text) 'this can save alot of time
            Char = Left(Text, CurPatternLen)
            If Left(Text, CurPatternLen * 2) = Char & Char Then
                PatternLen = CurPatternLen
                Do Until Right(Left(Text, PatternLen + CurPatternLen), CurPatternLen) <> Char Or PatternLen = Len(Text)
                    PatternLen = PatternLen + CurPatternLen
                Loop
                   
                If PatternLen > ShortestPattern And PatternLen > 6 Then
                    ReDim Preserve Patterns(1 To UBound(Patterns) + 1)
                    Patterns(UBound(Patterns)).Text = Char
                    Patterns(UBound(Patterns)).TimesRepeated = PatternLen / CurPatternLen
                    Patterns(UBound(Patterns)).Position = Len(Compress)
                   
                    Text = Right(Text, Len(Text) - PatternLen)
                Else
                    Compress = Compress & Left(Text, PatternLen)
                    Text = Right(Text, Len(Text) - PatternLen)
                End If
                GoTo PatternLoop
            End If
        Next
        Compress = Compress & Left(Text, 1)
        Text = Right(Text, Len(Text) - 1)
    Loop
   
    For x = 1 To UBound(Patterns)
        If Patterns(x).Text <> "" Then
            Compress = Patterns(x).Text & Compress
            Compress = Patterns(x).Position & " " & Compress
            Compress = Patterns(x).TimesRepeated & " " & Compress
            Compress = Len(Patterns(x).Text & Str(Patterns(x).TimesRepeated & Patterns(x).Position)) + 2 & " " & Compress
           
            Compressed = Compressed + 1
        End If
    Next
    Compress = Compressed & " " & Compress
       
End Function
Private Function Decompress(Text As String)
Dim Patterns() As Pattern
Dim Xstr As String
    If Left(Text, InStr(Text, " ") - 1) = 0 Then
        Decompress = Right(Text, Len(Text) - 2)
        Exit Function
    End If
    ReDim Patterns(1 To Left(Text, InStr(Text, " ") - 1))
    Text = Right(Text, Len(Text) - InStr(Text, " "))
   
    For x = 1 To UBound(Patterns)
        Xstr = Left(Text, InStr(Text, " ") - 1)
        Text = Right(Text, Len(Text) - Len(Xstr))
        Xstr = Left(Text, Xstr)
        Text = Right(Text, Len(Text) - Len(Xstr))
        Xstr = Right(Xstr, Len(Xstr) - 1)
       
        Patterns(x).TimesRepeated = Left(Xstr, InStr(Xstr, " ") - 1)
        Xstr = Right(Xstr, Len(Xstr) - InStr(Xstr, " "))
        Patterns(x).Position = Left(Xstr, InStr(Xstr, " "))
        Xstr = Right(Xstr, Len(Xstr) - InStr(Xstr, " "))
        Patterns(x).Text = Xstr
        Xstr = ""
    Next
   
    'Instrt Patterns into text
    For x = 1 To UBound(Patterns)
        Xstr = ""
        For Y = 1 To Patterns(x).TimesRepeated
            Xstr = Xstr & Patterns(x).Text
        Next
        Text = Left(Text, Patterns(x).Position) & Xstr & Right(Text, Len(Text) - Patterns(x).Position)
    Next

    Decompress = Text
End Function


You might also like...

Comments

Nick Avery I am as a web developer for a small company, working for a small company. I work on banking websites and verious related projects.

Contribute

Why not write for us? Or you could submit an event or a user group in your area. Alternatively just tell us what you think!

Our tools

We've got automatic conversion tools to convert C# to VB.NET, VB.NET to C#. Also you can compress javascript and compress css and generate sql connection strings.

“Brevity is the soul of wit” - Shakespeare