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?



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

Private Sub Init()

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

End Sub

Private Function Search(inp As String) As Integer

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

    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) = "" 

    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

    'End Error Checking
    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
            o = o & Chr(Search(CStr(p)))
            Add CStr(temp)
            p = c
        End If


    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
    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


    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

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.

You could use a 3rd Party OCX to do this such as ActiveZipper:
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

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.