visual basic, vb, active server pages, asp, DHTML, vbscript,java, javscript, c, c++, c__ , source, code, sample, samples, program, programs, routine, routines, source code, snippet, snippets, control, controls, class, classes, module

You are in:
 
The Basics
Visual Basic Home
Categories
Search
Submissions

Advanced
Newest Code
Top Code of Month
Top Code of All Time
Code of the Day
Coding Contest

Beyond the Code
Discuss
Tutorials
Recommend-
ed Reading

Customize

Miscellaneous
Site Home
Other Sites

Latest Code Ticker for Visual Basic
Click here to see a screenshot of this code! GetAllWindowsHwnd's(+childs), Put then in table
By M.C on 5/22

(Screen Shot)

Create Eye-Friendly Menus Using MouseOver
By Sparq on 5/22


Create Eye-Friendly Menus Using MouseOver
By Sparq on 5/22


Click here to see a screenshot of this code! DecHex Color Codes
By eboy on 5/22

(Screen Shot)

Click here to see a screenshot of this code! Display Current Mouse Pointer Image
By Will Brendel on 5/22

(Screen Shot)

Click here to see a screenshot of this code! Alarm Clock
By EXoDuS on 5/21

(Screen Shot)

MS Office Bar Code Macros for Excel and Access
By Brant Anderson on 5/21


Bar Code Check Digit Calculator & Printing Application
By Brant Anderson on 5/21


Mouse over
By Stewart MacFarlane on 5/21


A+ Screen Zoom
By Rocky Clark (Kath-Rock Software) on 5/21


Click here to see a screenshot of this code! Using Option Buttons in a Array
By Adam Spicer on 5/21

(Screen Shot)

FourSevens
By Glen A Jorgensen on 5/21


RANDOM CIRCLE GENERATOR
By Richard Banks on 5/21


Click here to see a screenshot of this code! JK Manager
By Denis Wiegand on 5/21

(Screen Shot)

Simple Update Checker
By Andrew on 5/21


Click here to see a screenshot of this code! Snap
By ZerO Invasion on 5/21

(Screen Shot)

Click here to see a screenshot of this code! MouseMove
By Alexandre Joly on 5/21

(Screen Shot)

Number 2 Letter - algorithm
By Max Christian Pohle on 5/21


File Explorer
By EXoDuS on 5/21


Click here to see a screenshot of this code! Dude Chat
By Travis Ruiz on 5/21

(Screen Shot)

Calculate Angles from the coords of three points
By Kevin Laity on 5/21


Julian Date Converter
By Data Management Systems on 5/21


Screen Manager
By Albert Nicholas Tedja on 5/21


Click here to see a screenshot of this code! Checkers AI
By Viper on 5/21

(Screen Shot)

enter
By Adam Short on 5/21


API Demo V2
By Andy McCurtin on 5/21


mCodE
By amaru on 5/21


MaxiClipper
By ZaMaX23 on 5/21


File Wiping
By Adam on 5/21


Click here to see a screenshot of this code! ActiveX - Scroll Text on Form with Kinjal's Text Scroll ActiveX Control
By Kinjal Patel on 5/20

(Screen Shot)

Click here to put this ticker on your site!


Click here to join the
'Code of the Day' Mailing List


   


  SQL Server Magazine  

   
Visual Basic Stats

Code: 585,335 lines
Users: 314 online
 
Search for: 
in language:
 
 
Sponsored by:
  Verio 468x60  
 

   
 


   

LZW Compression for VB strings\

VB icon
Submitted on: 6/13/1999
By: lcwd
Level: Not Given
User Rating: By 5 Users
Compatibility:VB 5.0/6.0

Users have accessed this code 1875 times.
 
 
     Yet another simple implementation of LZW compression for compressing VB strings. A 4K dictionary is used as suggested by the algorithm. A binary tree search is used for speeding up dictionary search. It accepts all the 256 characters. *** version 2 (23-Aug-99): bug fixed, performance improved ***
 
code:
Can't Copy and Paste this?
Click here for a copy-and-paste friendly version of this code!

						
'**************************************
' Name: LZW Compression for VB strings
' Description:Yet another simple impleme
'     ntation of LZW compression for compressi
'     ng VB strings. A 4K dictionary is used a
'     s suggested by the algorithm. A binary t
'     ree search is used for speeding up dicti
'     onary search. It accepts all the 256 cha
'     racters. *** version 2 (23-Aug-99): bug 
'     fixed, performance improved ***
' By: lcwd
'
'
' Inputs:None
'
' Returns:None
'
'Assumes:None
'
'Side Effects:None
'
'Warranty:
'code provided by Planet Source Code(tm)
'     (http://www.Planet-Source-Code.com) 'as 
'     is', without warranties as to performanc
'     e, fitness, merchantability,and any othe
'     r warranty (whether expressed or implied
'     ).
'Terms of Agreement:
'By using this source code, you agree to
'     the following terms...
' 1) You may use this source code in per
'     sonal projects and may compile it into a
'     n .exe/.dll/.ocx and distribute it in bi
'     nary format freely and with no charge.
' 2) You MAY NOT redistribute this sourc
'     e code (for example to a web site) witho
'     ut written permission from the original 
'     author.Failure to do so is a violation o
'     f copyright laws.
' 3) You may link to this code from anot
'     her website, provided it is not wrapped 
'     in a frame.
' 4) The author of this code may have re
'     tained certain additional copyright righ
'     ts.If so, this is indicated in the autho
'     r's description.
'**************************************

' Special thanks to Chris Dodge for repo
'     rting the bug
Option Explicit


Private Type BNode
    DictIdx As Long
    pLeft As Long
    pRight As Long
    End Type
    Dim Dict(4096) As String
    Dim NextDictIdx As Long
    Dim Heap(4096) As BNode
    Dim NextHeapIdx As Long
    Dim pStr As Long


Sub InitDict()

    Dim i As Integer
    


    For i = 0 To 255
        Dict(i) = Chr(i)
    Next i

    ' Not really necessary
    '
    ' For i = 256 To 4095
    'Dict(i) = ""
    ' Next i
    
NextDictIdx = 256

NextHeapIdx = 0

End Sub



Function AddToDict(s As String) As Long



    If NextDictIdx > 4095 Then
    NextDictIdx = 256

NextHeapIdx = 0

End If




If Len(s) = 1 Then
AddToDict = Asc(s)
Else
AddToDict = AddToBTree(0, s)
End If

End Function



Function AddToBTree(ByRef Node As Long, ByRef s As String) As Long

    Dim i As Integer
    


    If Node = -1 Or NextHeapIdx = 0 Then
        Dict(NextDictIdx) = s
        Heap(NextHeapIdx).DictIdx = NextDictIdx
    NextDictIdx = NextDictIdx + 1

    Heap(NextHeapIdx).pLeft = -1
    Heap(NextHeapIdx).pRight = -1
    Node = NextHeapIdx
NextHeapIdx = NextHeapIdx + 1

AddToBTree = -1
Else
i = StrComp(s, Dict(Heap(Node).DictIdx))


If i < 0 Then
    AddToBTree = AddToBTree(Heap(Node).pLeft, s)
ElseIf i > 0 Then
    AddToBTree = AddToBTree(Heap(Node).pRight, s)
Else
    AddToBTree = Heap(Node).DictIdx
End If

End If

End Function



Private Sub WriteStrBuf(s As String, s2 As String)



    Do While pStr + Len(s2) - 1 > Len(s)
        s = s & Space(100000)
    Loop

    Mid$(s, pStr) = s2
    pStr = pStr + Len(s2)
End Sub



Function Compress(IPStr As String) As String

    Dim TmpStr As String
    Dim Ch As String
    Dim DictIdx As Integer
    Dim LastDictIdx As Integer
    Dim FirstInPair As Boolean
    Dim HalfCh As Integer
    Dim i As Long
    Dim ostr As String
    
    InitDict
    FirstInPair = True
    pStr = 1
    


    For i = 1 To Len(IPStr)
        Ch = Mid$(IPStr, i, 1)
        DictIdx = AddToDict(TmpStr & Ch)


        If DictIdx = -1 Then


            If FirstInPair Then
                HalfCh = (LastDictIdx And 15) * 16
            Else
                WriteStrBuf ostr, Chr(HalfCh Or (LastDictIdx And 15))
            End If

            WriteStrBuf ostr, Chr(LastDictIdx \ 16)
            
            FirstInPair = Not FirstInPair
            
            TmpStr = Ch
            LastDictIdx = Asc(Ch)
        Else
            TmpStr = TmpStr & Ch
            LastDictIdx = DictIdx
        End If

    Next i

    
    WriteStrBuf ostr, _
    IIf(FirstInPair, Chr(LastDictIdx \ 16) & Chr((LastDictIdx And 15) * 16), _
    Chr(HalfCh Or (LastDictIdx And 15)) & Chr(LastDictIdx \ 16))
    Compress = Left(ostr, pStr - 1)
    
End Function



Function GC(str As String, position As Long) As Integer

    GC = Asc(Mid$(str, position, 1))
End Function



Function DeCompress(IPStr As String) As String

    Dim DictIdx As Integer
    Dim FirstInPair As Boolean
    Dim i As Long
    Dim s As String
    Dim s2 As String
    InitDict
    pStr = 1
    i = 1
    FirstInPair = True


    Do While i < Len(IPStr)


        If FirstInPair Then
            DictIdx = (GC(IPStr, i) * 16) Or (GC(IPStr, i + 1) \ 16)
            i = i + 1
        Else
            DictIdx = (GC(IPStr, i + 1) * 16) Or (GC(IPStr, i) And 15)
            i = i + 2
        End If

        FirstInPair = Not FirstInPair


        If i > 2 Then


            If DictIdx = NextDictIdx Or (DictIdx = 256 And NextDictIdx = 4096) Then
                AddToDict s2 & Left$(s2, 1)
            Else
                AddToDict s2 & Left$(Dict(DictIdx), 1)
            End If

        End If

        s2 = Dict(DictIdx)
        WriteStrBuf s, s2
    Loop

    
    DeCompress = Left(s, pStr - 1)
End Function



Sub test()

    Dim s As String
    MousePointer = vbHourglass
    
    s = Compress(Text1)
    Text2 = DeCompress(s)
    Text3 = Len(Text1)
    Text4 = Len(s)
    


    If Text1 <> Text2 Then
        Text5 = "error"
    Else
        Text5 = "ok"
    End If

    
    MousePointer = vbNormal
End Sub


Other 2 submission(s) by this author

 

 
Report Bad Submission
Use this form to notify us if this entry should be deleted (i.e contains no code, is a virus, etc.).
Reason:
 
Your Vote!

What do you think of this code(in the Not Given category)?
(The codewith your highest vote will win this month's coding contest!)
Excellent  Good  Average  Below Average  Poor See Voting Log
 
Other User Comments
6/13/1999 10:19:00 PM: Rick
Great piece of work!
Keep the Planet clean! If this comment was disrespectful, please click here.

 
6/14/1999 11:14:00 AM: Leigh
Excellent - Much nippier than the 
previous LZW code.
Keep the Planet clean! If this comment was disrespectful, please click here.

 
6/27/1999 8:02:00 PM: Kenneth
Can it be use to compress n decompress 
wavefile properly( only about 
3-4Megs)
If no, does anyone have 
source codes to compress 
and
decompresses wavefile format 
?Kindly please mail me and let me 
know
Thanks
Keep the Planet clean! If this comment was disrespectful, please click here.

 
7/13/1999 9:52:00 AM: Matt
um... every time I tried this, it would 
uncrease the size
example... I type 
"The Matrix" 10 characters
i get a 15 
character example, adding another half 
to the origional.  Im gonna look threw 
the code and see if i can find a 
problem but I wanted to know if there 
was an error
Keep the Planet clean! If this comment was disrespectful, please click here.

 
7/13/1999 10:21:00 AM: Matt (Again)
This program also cuts off words.  I 
thought it was actually encrypting well 
but it cut off my last two words
Keep the Planet clean! If this comment was disrespectful, please click here.

 
7/20/1999 12:02:00 AM: lcw
If you have large volume of data to 
compress, I would recommend the zlib 
compression library. It is free with 
source code in C.

LZ compression 
algorithms rely on redundant string 
segments in the input string. If there 
is no redundancy (e.g. when the string 
is extremely short), the output string 
can even be longer than the original 
one.

If your string is truncated 
after decompression, it is most likely 
that you have stored the compressed 
string in a text box rather than in a 
proper string variable. Text box cannot 
store non ASCII characters properly.
Keep the Planet clean! If this comment was disrespectful, please click here.

 
11/5/1999 9:17:00 AM: J-Ph. Constantin
If I create the input string from a 
table of pixel, can I use your code to 
compress GIF image ?
Keep the Planet clean! If this comment was disrespectful, please click here.

 
11/18/1999 12:48:00 AM: x1x1
Before adding strings to the dictionary 
using binary tree, bitwise operations 
are being performed on it. Why is it 
performed? What do the following 
statements do in the compress 
function?

HalfCh = (LastDictIdx And 
15) * 16

WriteStrBuf ostr, 
Chr(HalfCh Or (LastDictIdx And 
15))

Kindly let me know.Thanks.

Keep the Planet clean! If this comment was disrespectful, please click here.

 
11/19/1999 9:27:00 AM: lcwd
a)The algorithm is not compatible with 
GIF. Nevertheless, you can compress 
images with it.

b)In LZW, an output 
unit (which is the same as a key in the 
dictionary) is 12 bits (or 1.5 bytes). 
The least significant 4 bits of the 
first of each pair of output unit will 
be saved in HalfCh

	i.e. HalfCh = 
(LastDictIdx And 15) * 16

It will be 
output together with the following 1.5 
bytes

	i.e. WriteStrBuf ostr, 
Chr(HalfCh Or (LastDictIdx And 
15))


Keep the Planet clean! If this comment was disrespectful, please click here.

 
12/8/1999 9:36:00 PM: Tanner (Genesis Entertainment L.C.)
Very nice code!
Keep the Planet clean! If this comment was disrespectful, please click here.

 
12/30/1999 10:25:17 AM: Andy
Hi,

Looked at your code and it 
appears to be the correct 
implementation :) However I was 
wondering, I would like to code a 
little program that compresses binary 
files and decompresses them. Do I need 
to store the dictionary used in the 
compression at the end of the 
compressed file and then read it back 
when decompressing? or will this code 
generate the same dictionary 
regardless? Also are there issues when 
reading ASCII format binary files and 
converting them to vbUnicode then 
compressing them? i.e. they will be 
double byte and could possibly fall 
outside of the Asc function range you 
use. Hope you can find some time to 
call me back. Thanks in advance andy...
Keep the Planet clean! If this comment was disrespectful, please click here.

 
1/1/2000 6:54:55 AM: lcwd
Andy,

The beauty of LZW is that you 
don’t need to store a dictionary. 
The dictionary is generated on the fly 
during compression and 
decompression.

To compress a binary 
file, you can simply treat it as a byte 
stream. It doesn't matter whether it 
contains double byte characters or 
not.
Keep the Planet clean! If this comment was disrespectful, please click here.

 
2/1/2000 2:18:38 PM: Les Marshall
Nice tidy piece of code. Perfect for 
inclusion in other code since it is 
nice and unitary and Works!

Thanks 
much, 
Keep the Planet clean! If this comment was disrespectful, please click here.

 
Add Your Feedback!
Note:Not only will your feedback be posted, but an email will be sent to the code's author.

NOTICE: The author of this code has been kind enough to share it with you.  If you have a criticism, please state it politely or it will be deleted.

For feedback not related to this particular code, please click here.
 
Name:
Comment:

 
 
   
 
 

About the Site  |  Feedback  |  Link to the Site  |  Awards  |  Advertising

Copyright© 1997 by Exhedra Solutions, Inc. All Rights Reserved.   By using this site you agree to its Terms and Conditions.   Planet Source Code (tm) and the phrase "Dream It. Code It" (tm) are trademarks of Exhedra Solutions, Inc.