Kompresi File Teks

Contoh program kompresi FILE TEKS sederhana dengan tingkat kompresi antara 10% s/d 20%.
buatlah sebuah object baru dan tambahkan 2 command button, lalu ganti nama cmdCompress dan cmdDeCompress
kemudian copy paste kode ini.selanjutnya

Private Sub Decompress(FileName As String)
Dim Result As String
Dim Posisi As Double
Dim prevByte As Byte
Dim currByte As Byte
Dim AmbilBit As Byte
Dim andPrev, andCurr As Byte
Dim i, j As Double
Dim TempResult As Byte
Open FileName For Binary As #1
If Dir(Left(FileName, Len(FileName) – 3) + “tmp”) “” Then _
Kill Left(FileName, Len(FileName) – 3) + “tmp”
Open Left(FileName, Len(FileName) – 3) & “tmp” For Binary As #2
AmbilBit = 0
andPrev = &H1
andCurr = &HFC
For i = 1 To FileLen(FileName)
If AmbilBit = 0 Then
Get #1, i, currByte
currByte = currByte And &HFE
TempResult = currByte / 2
Else
Get #1, i – 1, prevByte
Get #1, i, currByte
prevByte = prevByte And andPrev
prevByte = prevByte * (2 ^ (8 – AmbilBit – 1))
currByte = currByte And andCurr
currByte = currByte / (2 ^ (AmbilBit + 1))
TempResult = prevByte Or currByte
End If
If AmbilBit = 7 Then
AmbilBit = 0
i = i – 1
andPrev = &H1
andCurr = &HFC
Else
AmbilBit = AmbilBit + 1
If AmbilBit > 1 Then
andPrev = andPrev + (2 ^ (AmbilBit – 1))
andCurr = &HFF – andPrev – (2 ^ AmbilBit)
End If
End If

TempResult = TempResult + &H20
Put #2, , TempResult
Next i
Close #1
Close #2

Open Left(FileName, Len(FileName) – 3) & “tmp” For Input As #3
Result = Input(FileLen(Left(FileName, _
Len(FileName) – 3) & “tmp”), #3)
Result = Replace(Result, Chr(&H7F), Chr(10), , , vbBinaryCompare)
Result = Replace(Result, Chr(&H80), Chr(13), , , vbBinaryCompare)
For i = 97 To 122
Result = Replace(Result, Chr(&H80 – 96 + i), _
Chr(i) + ” “, , , vbBinaryCompare)
Next i

Close #3

Kill Left(FileName, Len(FileName) – 3) & “tmp”
If Dir(Left(FileName, Len(FileName) – 3) + “txt”) “” Then _
Kill Left(FileName, Len(FileName) – 3) + “txt”

Open Left(FileName, Len(FileName) – 3) & “txt” For Binary As #4
Put #4, , Result
Close #4
End Sub

Private Sub Compress(FileName As String)
Dim i As Byte
Dim IsiText As String
Dim Posisi As Double
Dim String8 As String
Dim Temp1 As Byte
Dim Temp2 As Byte
Dim currTemp As Integer
Posisi = 1
Open FileName For Input As #1
IsiText = Input(FileLen(FileName), #1)
Close #1

If Dir(Left(FileName, Len(FileName) – 3) + “ZZZ”) “” Then _
Kill Left(FileName, Len(FileName) – 3) + “ZZZ”
Open Left(FileName, Len(FileName) – 3) + “ZZZ” For Binary As #2
IsiText = Replace(IsiText, Chr(10), Chr(&H7F), _
, , vbBinaryCompare)
IsiText = Replace(IsiText, Chr(13), Chr(&H80), _
, , vbBinaryCompare)

For i = 97 To 122
IsiText = Replace(IsiText, Chr(i) + ” “, _
Chr(&H80 – 96 + i), , , vbBinaryCompare)
Next i
Do While Posisi < Len(IsiText)
String8 = Mid(IsiText, Posisi, 8)
Posisi = Posisi + 8
ReDim ByteTemp8(Len(String8) – 1) As Byte
ReDim ByteResult7(Round((Len(String8) * 7) / 8 + _
0.4) – 1) As Byte

For i = 1 To Len(String8)
ByteTemp8(i – 1) = (Asc(Mid(String8, i, 1)) – &H20)
Next i
currTemp = 128
Temp2 = 0

ByteResult7(0) = ByteTemp8(0) * 2
For i = 1 To UBound(ByteResult7)
ByteTemp8(i) = ByteTemp8(i) * 2
Temp2 = Temp2 + currTemp
currTemp = currTemp / 2
Temp1 = ByteTemp8(i) And Temp2
Temp1 = Temp1 / (2 ^ (8 – i))
ByteResult7(i – 1) = ByteResult7(i – 1) Or Temp1
ByteTemp8(i) = ByteTemp8(i) And (&HFF – Temp2)
ByteTemp8(i) = ByteTemp8(i) * (2 ^ i)
ByteResult7(i) = ByteTemp8(i)
Next i
If Len(String8) = 8 Then _
ByteResult7(6) = ByteResult7(6) Or ByteTemp8(7)
Put #2, , ByteResult7
Loop
Close #2
End Sub

Private Sub cmdCompress_Click()
Compress “c:\test.txt”
End Sub

Private Sub cmdDeCompress_Click()
Decompress “c:\test.txt”
End Sub

(Originally Published By Rudin Harianto)