phuzzy
asked on
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
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
http://www.iessoft.com/scripts/interfac.asp