by Lajili Houssem (6 Submissions)
Category: Files/File Controls/Input/Output
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Sat 1st February 2003
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
This code compress and uncompress file like winzip.It is slow but it work.
VBcoders
VERSION 5.00
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "LH Archiver By LH-Soft"
ClientHeight = 1545
ClientLeft = 45
ClientTop = 330
ClientWidth = 5025
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
OLEDropMode = 1 'Manual
ScaleHeight = 1545
ScaleWidth = 5025
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton Command2
Caption = "Uncompress file"
Height = 375
Left = 3480
TabIndex = 4
Top = 600
Width = 1335
End
Begin VB.CommandButton Command1
Caption = "Compress file"
Height = 375
Left = 3480
TabIndex = 2
Top = 120
Width = 1335
End
Begin VB.TextBox t2
Height = 285
Left = 1080
TabIndex = 1
Top = 600
Width = 2175
End
Begin VB.TextBox t1
Height = 285
Left = 1080
TabIndex = 0
Top = 120
Width = 2175
End
Begin VB.Label Label2
Alignment = 2 'Center
Caption = "Destination file"
Height = 375
Index = 1
Left = 120
TabIndex = 6
Top = 600
Width = 855
End
Begin VB.Label Label2
Alignment = 2 'Center
Caption = "Source file"
Height = 255
Index = 0
Left = 120
TabIndex = 5
Top = 120
Width = 855
End
Begin VB.Label Label1
Alignment = 2 'Center
Height = 255
Left = 0
TabIndex = 3
Top = 1080
Width = 5055
End
Begin VB.Line Line1
BorderWidth = 8
X1 = 0
X2 = 15
Y1 = 1440
Y2 = 1455
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Function clm(txt, rnn)
If Len(txt) = 1 Then clm = "0" & txt Else clm = txt
End Function
Function asb(txt, nb)
If Len(txt) <> 1 Then Exit Function
For g = 1 To nb
asb = asb & txt
Next g
End Function
Private Sub Command1_Click()
Set fs = CreateObject("scripting.filesystemobject")
Set d = fs.getfile(t1)
Label1 = "Reading original file..."
DoEvents
Set g = d.openastextstream(1)
text1 = g.read(d.Size)
g.Close
Set i = fs.createtextfile(t2)
text2 = ""
For t = 1 To Len(text1)
tt = tt + 1
If tt = 10000 Then tt = 0
If tt = 0 Then DoEvents
lt = Mid(text1, t, 1)
f = t
rnn = "X"
Do
If Mid(text1, f + 1, 1) <> lt Or f - t = 9998 Then Exit Do
f = f + 1
Loop
If f - t > 8 Then rnn = "Y"
If f - t > 98 Then rnn = "Z"
If f - t > 998 Then rnn = "S"
If f = t Then i.write lt Else If f - t < 3 Then i.write asb(lt, f - t + 1) Else i.write asb(rnn, 3) & f - t + 1 & lt
t = t + f - t
Label1 = FormatNumber(t / Len(text1) * 100, 0) & " % Compressing file..."
Line1.X2 = (t / Len(text1)) * 5000
Next t
i.Close
Set d3 = fs.getfile(t2)
Label1 = "Done " & FormatNumber(d3.Size / t * 100, 1) & "% of original file writted"
End Sub
Private Sub Command2_Click()
Set fs = CreateObject("scripting.filesystemobject")
Set d = fs.getfile(t2)
Label1 = "Reading original file..."
DoEvents
Set g = d.openastextstream(1)
text2 = g.read(d.Size)
Set i = fs.createtextfile(t1)
text1 = ""
For t = 1 To Len(text2)
tt = tt + 1
If tt = 10000 Then tt = 0
If tt = 0 Then DoEvents
lt = Mid(text2, t, 1)
f = t
kkk = Mid(text2, t, 3)
If Mid(text2, t, 3) = "XXX" Then lt = asb(Mid(text2, t + 4, 1), Mid(text2, t + 3, 1)): t = t + 4
If Mid(text2, t, 3) = "YYY" Then lt = asb(Mid(text2, t + 5, 1), Mid(text2, t + 3, 2)): t = t + 5
If Mid(text2, t, 3) = "ZZZ" Then lt = asb(Mid(text2, t + 6, 1), Mid(text2, t + 3, 3)): t = t + 6
If Mid(text2, t, 3) = "SSS" Then lt = asb(Mid(text2, t + 7, 1), Mid(text2, t + 3, 4)): t = t + 7
i.write lt
h:
Label1 = FormatNumber(t / Len(text2) * 100, 0) & " % Uncompressing file..."
Line1.X2 = (t / Len(text2)) * 5000
Next t
Label1 = "Done"
End Sub
Private Sub Form_Load()
If Command$ <> "" Then t1 = Command$: t2 = t1 & ".co"
End Sub
Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
t1 = Data.Files(1)
t2 = t1 & ".co"
End Sub
No comments have been posted about This code compress and uncompress file like winzip.It is slow but it work.. Why not be the first to post a comment about This code compress and uncompress file like winzip.It is slow but it work..
