Ce programme permet de compresser un ou plusieurs fichiers(texte, binaire...)
Il utilise un ecran avec
-une zone de texte contenant le nom du fichier resultat
-une liste permettant de faire la selection des fichiers
-un bouton lancant la compression.
NOTE :
Ce programme peut etre largement amélioré au niveau de la compression.
C'est un exemple comme base de travail!
Source / Exemple :
Public chemin
Public disque
' PROGRAMME DE COMPRESSION DE DONNEES
' VIENT GERARD (FRANCE)
' Prévu pour le disque C:
' CECI EST UN EXEMPLE MAIS IL FAUDRAIT AMELIORER LA COMPRESSION
' ET LA RAPIDITE DU PROGRAMME ....
' En decompression on met le resultat dans c:\temp
'
' prévoir un écran avec deux zones de texte
' une zone de saisie pour le nom du fichier compressé
' une zone liste (dir1) contenant les repertoires
' une zone liste (file1) contenant les fichiers du repertoire
' deux boutons radios pour chosir le disque (c ou d)
' deux boutons commandes pour compresser ou decompresser
'
Private Sub CommandButton1_Click()
'
If Len(Dir(text1.Text)) <> 0 Then
Kill text1.Text
End If
Dim table(5000) As String, table2(5000) As Long, table3(255) As Long, table4(10) As String, table5(10) As Long, car As String, totalfichier As String, remplacement As String, cart As String, carr As String, resultat As String, ligne As String, ligne2 As String
Position = 1
tailletot = 0
For i = 0 To file1.ListCount - 1
If file1.Selected(i) Then
poslong = Position + 32
Open chemin + file1.List(i) For Binary As 1
taille = LOF(1)
tailletot = tailletot + taille
totalfichier = String(taille, " ")
Get #1, 1, totalfichier
Close 1
Label2.Caption = "TRAITEMENT CHOIX " + file1.List(i) + " TAILLE EN OCTETS : " + Str(taille)
blanc = String(128, " ")
'
' on écrit le nombre de caractère disponibles pour la répétition
'
g = 1
temp3 = ""
Erase table, table2, table3, table4, table5
pos = 1
maxix = 0
taille2 = taille + 1
While pos > 0
temp = Str(Int(g / taille * 100))
If temp <> temp3 Then
Label2.Caption = "TRAITEMENT LECTURE " + file1.List(i) + temp + "%"
UserForm1.Repaint
temp3 = temp
End If
fin = True
mot = ""
While fin
car = Mid(totalfichier, pos, 1)
pos = pos + 1
mot = mot + car
tp = Asc(car + " ")
table3(tp) = table3(tp) + 1
If Len(mot) = 4 Or car = "" Then fin = False
Wend
If pos > Len(totalfichier) Then pos = 0
If pos > 0 Then
If Len(mot) >= 2 Then
trouve = False
For h = 0 To maxix
If mot = table(h) Then
table2(h) = table2(h) + 1
h = maxix
trouve = True
End If
Next h
If trouve = False And maxix < 250 Then
maxix = maxix + 1
table(maxix) = mot
table2(maxix) = 1
End If
End If
g = pos
End If
Wend
'
' on tri determine les caracteres
' à répéter
'
tri = True
While tri
tri = False
For g = 0 To maxix
For h = g + 1 To maxix
If table2(g) * Len(table(g)) < table2(h) * Len(table(h)) Then
tt1 = table(g)
tt2 = table2(g)
table(g) = table(h)
table2(g) = table2(h)
table(h) = tt1
table2(h) = tt2
tri = True
End If
Next h
Next g
Wend
'
' tri des caracteres du moins vers le plus
' pour utiliser les caracteres de repetitions qui apparaissent
' le moins dans le fichier
'
For g = 0 To 10
table5(g) = 999999999#
Next g
For g = 0 To 255
For h = 0 To 10
If table5(h) > table3(g) Then
table5(h) = table3(g)
table4(h) = Chr(g)
h = 10
End If
Next h
Next g
Open text1.Text For Binary As 2
'
' on prepare les 4 octets de la longueur du fichier
'
ligne = MKL(0)
Put #2, Position, ligne
Position2 = Position
Position = Position + 4
'
' on ecrit le caractère de remplacement
'
ligne = table4(0)
Put #2, Position, ligne
Position = Position + 1
'
' on ecrit la longueur du nom de fichie reel
'
ligne = Chr(Len(Trim(file1.List(i))))
Put #2, Position, ligne
Position = Position + 1
'
' on ecrit le nom du fichier reel
'
ligne = Trim(file1.List(i))
Put #2, Position, ligne
Position = Position + Len(ligne)
'
' on ecrit les occurences des chaines
' 1 caractere de repetition
' 1 caractere pour la longueur de la zone repete
' la zone repete
'
For g = 0 To 9
mot = table(g)
ligne = table4(g + 1)
Put #2, Position, ligne
Position = Position + 1
ligne = Chr(Len(mot))
Put #2, Position, ligne
Position = Position + 1
ligne = mot
Put #2, Position, ligne
Position = Position + Len(ligne)
Next g
g = 1
carr = table4(0)
Position3 = Position
While g <= Len(totalfichier)
cart = Mid(totalfichier, g, 1)
temp = Str(Int(g / taille2 * 100))
If temp <> temp3 Then
Label2.Caption = "TRAITEMENT ECRITURE " + file1.List(i) + temp + "%"
UserForm1.Repaint
temp3 = temp
End If
For h = 0 To 9
mot = table4(h + 1)
If cart = mot Then
ligne = carr + mot
Put #2, Position, ligne
Position = Position + 2
g = g + 1
h = 99
Else
mot = table(h)
If mot <> "" Then
If Mid(totalfichier, g, Len(mot)) = mot Then
ligne = table4(h + 1)
Put #2, Position, ligne
Position = Position + 1
g = g + Len(mot)
h = 99
End If
End If
End If
Next h
If cart = carr Then
ligne = carr + cart
Put #2, Position, ligne
Position = Position + 2
g = g + 1
Else
If h < 99 Then
ligne = cart
Put #2, Position, ligne
Position = Position + 1
g = g + 1
End If
End If
Wend
ligne = MKL(Position - Position3)
Put #2, Position2, ligne
taillecomp = LOF(2)
Close #2
'
' on ecrit les caracteres de répétition
'
If taille > 0 Then Label2.Caption = file1.List(i) + "(" + Str(Int((Position - Position2) / Len(totalfichier) * 100)) + "%)"
End If
Next i
MsgBox "OK TRAITEMENT TERMINE TAILE AVANT EN OCTETS" + Str(tailletot) + " TAILLE APRES " + Str(taillecomp) + "(" + Str(Int((taillecomp / tailletot) * 100)) + "%)"
End Sub
Private Sub CommandButton2_Click()
Dim zone As String
Dim tabler(10) As String, tablel(10) As Long, tablem(10) As String
Open text1.Text For Binary As 1
Position = 1
While Position <= LOF(1)
zone = "xxxx"
Get #1, Position, zone
Position = Position + Len(zone)
longueurc = CVL(zone)
zone = "x"
Get #1, Position, zone
Position = Position + Len(zone)
carr = zone
Get #1, Position, zone
Position = Position + Len(zone)
lnom = Asc(zone)
zone = String(lnom, " ")
Get #1, Position, zone
Position = Position + Len(zone)
nomfic = zone
For g = 1 To 10
zone = "x"
Get #1, Position, zone
Position = Position + Len(zone)
tabler(g) = zone
Get #1, Position, zone
Position = Position + Len(zone)
tablel(g) = Asc(zone)
zone = String(tablel(g), "x")
Get #1, Position, zone
Position = Position + Len(zone)
tablem(g) = zone
Next g
'
' on remet le fichier dans temp
'
Label2.Caption = "TRAITEMENT DU FICHIER " + nomfic + Str(longueurc)
UserForm1.Repaint
Position2 = 1
Open "c:\temp\" + nomfic For Binary As 2
zone = "x"
taille2 = longueurc + 1
For g = 1 To longueurc
Get #1, Position, zone
Position = Position + Len(zone)
temp = Str(Int(Position / taille2 * 100))
If temp <> temp3 Then
Label2.Caption = "TRAITEMENT DU FICHIER " + nomfic + temp + "%"
UserForm1.Repaint
temp3 = temp
End If
If zone = carr Then
Get #1, Position, zone
Position = Position + Len(zone)
Put #2, Position2, zone
Position2 = Position2 + Len(zone)
Else
trouve = False
For h = 1 To 10
If zone = tabler(h) Then
Put #2, Position2, tablem(h)
Position2 = Position2 + Len(tablem(h))
trouve = True
h = 10
End If
Next h
If Not trouve Then
Put #2, Position2, zone
Position2 = Position2 + Len(zone)
End If
End If
Next g
Close #2
Wend
Close #1
MsgBox "TRAITEMENT TERMINE RESULTAT DANS C:\temp"
End Sub
Private Sub dir1_Change()
End Sub
Private Sub dir1_Click()
For i = 0 To dir1.ListCount - 1
If dir1.Selected(i) Then
chemin = chemin + dir1.List(i) + "\"
End If
Next i
dir1.Clear
file1.Clear
myname = Dir(chemin)
nb = 1
Do While myname <> "" ' Commence la boucle.
' Ignore le répertoire courant et le répertoire
' contenant le répertoire courant.
If myname <> "." And myname <> ".." Then
' Utilise une comparaison au niveau du bit pour
' vérifier que MyName est un répertoire.
file1.AddItem (myname)
End If
myname = Dir ' Extrait l'entrée suivante.
Loop
MyPath = chemin ' Définit le chemin d'accès.
' Extrait la première entrée.
myname = Dir(MyPath, vbDirectory)
nb = 1
Do While myname <> "" ' Commence la boucle.
If (GetAttr(MyPath & myname) _
And vbDirectory) = vbDirectory Then
dir1.AddItem (myname)
End If
myname = Dir ' Extrait l'entrée suivante.
Loop
UserForm1.Repaint
End Sub
Private Sub Label2_Click()
End Sub
Private Sub TextBox1_Change()
End Sub
Private Sub ListBox2_Click()
End Sub
Private Sub OptionButton1_Click()
dir1.Clear
file1.Clear
chemin = "c:\"
myname = Dir(chemin)
nb = 1
Do While myname <> "" ' Commence la boucle.
' Ignore le répertoire courant et le répertoire
' contenant le répertoire courant.
If myname <> "." And myname <> ".." Then
' Utilise une comparaison au niveau du bit pour
' vérifier que MyName est un répertoire.
file1.AddItem (myname)
End If
myname = Dir ' Extrait l'entrée suivante.
Loop
MyPath = chemin
' Extrait la première entrée.
myname = Dir(MyPath, vbDirectory)
nb = 1
Do While myname <> "" ' Commence la boucle.
If (GetAttr(MyPath & myname) _
And vbDirectory) = vbDirectory Then
dir1.AddItem (myname)
End If
myname = Dir ' Extrait l'entrée suivante.
Loop
End Sub
Private Sub OptionButton2_Click()
dir1.Clear
file1.Clear
chemin = "d:\"
myname = Dir(chemin)
nb = 1
Do While myname <> "" ' Commence la boucle.
' Ignore le répertoire courant et le répertoire
' contenant le répertoire courant.
If myname <> "." And myname <> ".." Then
' Utilise une comparaison au niveau du bit pour
' vérifier que MyName est un répertoire.
file1.AddItem (myname)
End If
myname = Dir ' Extrait l'entrée suivante.
Loop
MyPath = chemin
' Extrait la première entrée.
myname = Dir(MyPath, vbDirectory)
nb = 1
Do While myname <> "" ' Commence la boucle.
If (GetAttr(MyPath & myname) _
And vbDirectory) = vbDirectory Then
dir1.AddItem (myname)
End If
myname = Dir ' Extrait l'entrée suivante.
Loop
End Sub
Private Sub UserForm_Activate()
'
' on travaille sur le disque c:
'
disque = "c:"
MyPath = disque + "\" ' Définit le chemin d'accès.
chemin = disque + "\"
' Extrait la première entrée.
myname = Dir(MyPath)
nb = 1
Do While myname <> "" ' Commence la boucle.
' Ignore le répertoire courant et le répertoire
' contenant le répertoire courant.
If myname <> "." And myname <> ".." Then
' Utilise une comparaison au niveau du bit pour
' vérifier que MyName est un répertoire.
file1.AddItem (myname)
End If
myname = Dir ' Extrait l'entrée suivante.
Loop
MyPath = disque + "\" ' Définit le chemin d'accès.
' Extrait la première entrée.
myname = Dir(MyPath, vbDirectory)
nb = 1
Do While myname <> "" ' Commence la boucle.
If (GetAttr(MyPath & myname) _
And vbDirectory) = vbDirectory Then
dir1.AddItem (myname)
End If
myname = Dir ' Extrait l'entrée suivante.
Loop
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub Command1_Click()
End Sub
Function MKL(chiffre)
'
' sp pour transformer un nombre en 4 caractères
' Note : nombre entier et positif
'
Dim x1 As Long, x2 As Long, x3 As Long
x1 = 256# * 256# * 256#
x2 = 256# * 256#
x3 = 256#
chiffre2 = chiffre
a1$ = Chr(Int(chiffre2 / x1))
chiffre2 = chiffre2 - Asc(a1$) * x1
a2$ = Chr(Int(chiffre2 / x2))
chiffre2 = chiffre2 - Asc(a2$) * x2
a3$ = Chr(Int(chiffre2 / x3))
chiffre2 = chiffre2 - Asc(a3$) * x3
a4$ = Chr(Int(chiffre2))
MKL = a1$ + a2$ + a3$ + a4$
End Function
Function CVL(zone As String)
'
' sp pour transformer un nombre en 4 caractères
' Note : nombre entier et positif
'
Dim x1 As Long, x2 As Long, x3 As Long
x1 = 256# * 256# * 256#
x2 = 256# * 256#
x3 = 256#
CVL = Asc(Left(zone, 1)) * x1 + Asc(Mid(zone, 2, 1)) * x2 + Asc(Mid(zone, 3, 1)) * x3 + Asc(Right(zone, 1))
End Function
Conclusion :
Le principe :
- Le programme lit le fichier à compresser.
- Il analyse les caractères les moins utiliser et le plus utiliser.
Il écrit un fichier compresser en se servant des caractères les moins présents pour code de répétition.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.