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
String compression
By Nick Avery, published on 06 Sep 2001
| Filed in
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.
You might also like...
I am as a web developer for a small company, working for a small company. I work on banking websites and verious related projects.
Patterns forum discussion
-
CorelDRAW VBA: cdrTraceLineDrawing FAILS, producing single linear path instead of Centerline trace?
by dancemanj (0 replies)
-
client/server application using activex
by beautifulheart (0 replies)
-
System Error &H8007007E. The specifed module could not be found.
by swiftsafe (5 replies)
-
Invitation to take part in an academic research study
by researchlab (0 replies)
-
Send SMS with SMPP
by mmahmoud (0 replies)
Patterns podcasts
-
Stack Overflow Podcast: Podcast #45 – Keeping it Sharp
Published 7 years ago, running time 0h54m
Our guest this week is Eric Lippert – language architect extraordinaire and famous for all his work at Microsoft in developing their languages Eric joined Microsoft right out of college and was originally working on VB It’s time for everyone’s favorite game: Name the Worst Feature of that Microso.
Comments