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?

[Webinar] Streamline your web hosting managementRegister Today

x
 
VbmasterConnect With a Mentor Commented:
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
 
Erick37Commented:
You could use a 3rd Party OCX to do this such as ActiveZipper:

http://www.iessoft.com/scripts/interfac.asp
0
All Courses

From novice to tech pro — start learning today.