Compression Code Adpat

I have VB code that performs a compression routine on a string but i was wondering how it could be adapted to take a file name in from, say, a textbox and compress the file creating another file in the process?

CODE FOLLOWS

==========================

Private Dict(0 To 255) As String
Private Count As Integer


Private Sub Init()



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


End Sub



Private Function Search(inp As String) As Integer



    For i = 0 To 255
        If Dict(i) = inp Then Search = i: Exit Function
    Next


    Search = 256
End Function



Private Sub Add(inp As String)


    If Count = 256 Then Wipe
    Dict(Count) = inp
    Count = Count + 1
End Sub



Private Sub Wipe()



    For i = 128 To 255
        Dict(i) = "" 
    Next


    Count = 128
End Sub



Public Function Deflate(inp As String) As String


    'Begin Error Checking
    If Len(inp) = 0 Then Exit Function


    For i = 1 To Len(inp)
        If Asc(Mid(inp, i, 1)) > 127 Then MsgBox "Illegal Character Value", vbCritical, "Error:": Exit Function
    Next


    'End Error Checking
    Init
    Wipe
    p = "" 
    i = 1


    Do Until i > Len(inp)
        c = Mid(inp, i, 1)
        i = i + 1
        temp = p & c


        If Not Search(CStr(temp)) = 256 Then
            p = temp
        Else
            o = o & Chr(Search(CStr(p)))
            Add CStr(temp)
            p = c
        End If


    Loop


    o = o & Chr(Search(CStr(p)))
    Deflate = o
End Function



Public Function Inflate(inp As String) As String


    If Len(inp) = 0 Then Exit Function
    Init
    Wipe
    cW = Asc(Mid(inp, 1, 1))
    o = Dict(cW)
    i = 2


    Do Until i > Len(inp)
        pW = cW
        cW = Asc(Mid(inp, i, 1))
        i = i + 1


        If Not Dict(cW) = "" Then
            o = o & Dict(cW)
            p = Dict(pW)
            c = Mid(Dict(cW), 1, 1)
            Add (CStr(p) & CStr(c))
        ElseIf Dict(cW) = "" Then
            p = Dict(pW)
            c = Mid(Dict(pW), 1, 1)
            o = o & p & c
            Add (CStr(p) & CStr(c))
        End If


    Loop


    Inflate = o
End Function



Public Sub main()


    inp = "dhfjkdshfhsdk"
    d = Deflate(CStr(inp)) 'Compress
    q = Inflate(CStr(d)) 'Uncompress
    MsgBox "Uncompressed: " & q & vbCrLf & vbCrLf & _
    "Compressed: " & d & vbCrLf & vbCrLf & _
    "Compressed Size: " & Len(d) & vbCrLf & vbCrLf & _
    "Uncompressed Size: " & Len(q) & vbCrLf & vbCrLf & _
    "Compression Ratio: " & (100 - (((Len(d) / Len(q)) * 100) \ 1)) & "%", vbOKOnly, "Results:"
End Sub





phuzzyAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Erick37Commented:
You could use a 3rd Party OCX to do this such as ActiveZipper:

http://www.iessoft.com/scripts/interfac.asp
0
VbmasterCommented:
Or you could get a comment that answers your question

To compress a file (file_to_compress) into another file (new_filename):

Call OutputFile(new_filename, Deflate(InputFile(file_to_compress)))

To uncompress a file (compressed_file) into another file (new_filename_that_is_uncompressed):

Call OutputFile(new_filename_that_is_uncompressed, Inflate(InputFile(compressed_file)))


This requires you to add these functions, they are kinda good to use for other purposes too. ;)

Function InputFile(FileName As String) As String

  Dim Filenr As Long
 
  Filenr = FreeFile
  Open FileName For Input Lock Read As Filenr
  InputFile = Input$(LOF(Filenr), Filenr)
  Close Filenr

End Function

Function OutputFile(FileName As String, Text As String)

  Dim Filenr As Integer
 
  Filenr = FreeFile
  Open FileName For Output Lock Read As #Filenr
  Print #Filenr, Text
  Close #Filenr

End Function
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Visual Basic Classic

From novice to tech pro — start learning today.