Test réalisé sur Cyrix II 300 64Mo Ram.
Vitesse compression: 2Ko/s env
Vitesse décompression: 3Ko/s env
Vitesse variable selon fichiers
Taux de compression: faible (50 % max selon redondances de motifs)
Module VB5 j'espère assez documenté. Théoriquement applicable pour VB3,4,5,6 (pas de forms ni de fonctions spécifiques).
' Module développé par Philippe LARASSE le 03.07.2000
Option Explicit
Dim nx As Long, xx As String, nn As Long, fich0 As String, fich1 As String, msg As String
Dim hr1 As Variant, hr2 As Variant
Sub Main()
Dim lchoix As String
msg = ""
Do
If MsgBox("OUI = Compression , NON = Décompression", vbYesNo, "Essai Comp/Dcomp") = vbYes Then
lchoix = "Compresser"
Else
lchoix = "Décompresser"
End If
fich0 = InputBox$(lchoix & " quel fichier ?" & Chr(13) & "(Chemin + nom)", lchoix, fich0)
If fich0 = "" Then
Exit Do
Else
fich1 = InputBox$(lchoix & " le fichier: " & Chr(13) & fich0 & Chr(13) & "Vers quel fichier ?" & Chr(13) & "(Chemin + nom)", lchoix, fich1)
If fich1 = "" Then
Exit Do
Else
If lchoix = "Compresser" Then
Call compresser1
Else
Call decompresser1
End If
MsgBox msg, vbOKOnly, "Résultat"
If MsgBox("Continuer ?", vbYesNo, "COMP/DECOMP") = vbNo Then
Exit Do
End If
End If
End If
Loop
End
End Sub
Sub compresser1()
hr1 = Time
Dim code As String, ctrl As String, buff As String
Dim pnt As Long, enr As String, cur As Integer, lcur As Integer
Dim mot As String, trouve As Integer, limit As Long
Dim lcode As Long, atrouve As Integer, alcur As Integer, amot As String
Close
Open fich1 For Binary As #1
Close
Kill fich1
Open fich0 For Binary As #1
Open fich1 For Binary As #2
' lecture par blocs de 16382 octets
' buffer : fenêtre du buffer
buff = String(16382, " ")
Get #1, 1, buff
Put #2, 1, buff
' les 16382 premiers octets ne sont pas compressés
' puisqu'on va chercher dans la chaîne le mot à coder
pnt = 16382
' pointeur de lecture
Do While pnt < LOF(1)
If pnt + 16382 > LOF(1) Then
enr = String(LOF(1) - pnt, " ")
' s'il ne reste pas 16382 octets, lire ce qui reste
Else
' sinon lire 16382 octets
enr = String(16382, " ")
End If
Get #1, , enr
pnt = pnt + Len(enr)
' enr : chaîne à coder
cur = 1: lcur = 1: mot = ""
' cur: position courante
' lcur: longueur courante
Do
mot = Mid(enr, cur, lcur)
'lecture du mot à coder
trouve = InStr(1, buff, mot)
' trouve = position du mot dans buffer
If lcur + cur > Len(enr) Then
' si dépassement : considéré comme non-trouvé
trouve = 0
End If
If trouve > 0 Then
' mot trouvé !
' alcur,amot,atrouve : sauvegarde de lcur,mot,trouve
alcur = lcur
amot = mot
lcur = lcur + 1
' on va chercher un mot plus long
atrouve = trouve
Else
' mot non-trouvé
If lcur < 5 Then
' si le mot a été trouvé avant et que sa longueur est < 5
' ou que le mot n'a jamais été trouvé
' écrire le mot + topage non-codé pour chaque octet écrit
Put #2, , mot
ctrl = ctrl & String(lcur, "0")
Else
' sinon, écrire la position trouvée dans le buffer
Put #2, , atrouve
' écrire la longueur du mot trouvé
Put #2, , alcur
' re-définir la longueur actuelle compte tenu du mot trouvé
lcur = alcur
' toper l'enregistrement comme codé
ctrl = ctrl & "1"
' re-définir le mot trouvé
mot = amot
End If
' stockage du mot en fin de buffer
buff = buff & mot
' on passe en position après le mot
cur = cur + lcur
If cur > Len(enr) Then
' au-delà de la chaîne
Exit Do
Else
' longueur en cours réinitialisée à 1
lcur = 1
End If
mot = ""
End If
Loop
' la chaîne a été totalement explorée:
' le buffer a atteint 32764 octets maxi
' re-définir le buffer comme étant la chaîne qui vient d'être explorée
buff = enr
' calcul du code de contrôle de codage
Do
If Len(ctrl) < 8 Then
Exit Do
ElseIf Len(ctrl) = 8 Then
code = code & Chr(btod(ctrl))
ctrl = ""
Else
code = code & Chr(btod(Left(ctrl, 8)))
ctrl = Right(ctrl, Len(ctrl) - 8)
End If
Loop
' note: il peut rester une chaine binaire dans ctrl
Loop
limit = Len(code) * 8 + Len(ctrl)
' limit: LONG définissant la taille réelle du code binaire de contrôle
If ctrl <> "" Then
' on traite le reliquat de ctrl
ctrl = ctrl & String(8 - Len(ctrl), "0")
code = code & Chr(btod(ctrl))
End If
' écriture du 'bloc de fin'
' Code de contrôle de codage
Put #2, , code
lcode = Len(code)
' longueur du code (type LONG)
Put #2, , lcode
' taille réelle du code binaire de contrôle
Put #2, , limit
msg = "Taille origine : " & LTrim(Str(LOF(1))) & Chr(13)
msg = msg & "Taille comprimé: " & LTrim(Str(LOF(2)))
hr2 = Time
msg = msg & Chr(13) & "Taux : " & LTrim(Str(Int(1 - (LOF(2) / LOF(1)) * 100 + 0.5))) & " %"
msg = msg & Chr(13) & "Vitesse : " & LTrim(Str(Int(LOF(1) / ((hr2 - hr1) * 100000)))) & " octets/seconde"
Close
End Sub
Sub decompresser1()
hr1 = Time
Dim code As String, ctrl As String, buff As String
Dim pnt As Long, enr As String, cur As Integer, lcur As Integer
Dim trouve As Integer, limit As Long
Dim lcode As Long, atrouve As Integer, ecode As Integer, bcode As String
Dim i As Long, j As Long
Close
Open fich1 For Binary As #1
Close
Kill fich1
Open fich0 For Binary As #1
Open fich1 For Binary As #2
' lecture de la taille réelle du code binaire de contrôle
Get #1, LOF(1) - 3, limit
' lecture de la taille du code de contrôle de codage (type LONG = 4 octets)
Get #1, LOF(1) - 7, lcode
' lecture du code de contrôle de codage
code = String(lcode, " ")
Get #1, LOF(1) - 7 - lcode, code
' définition du buffer à 16 Ko - 2 octets
buff = String(16382, " ")
' lecture
Get #1, 1, buff
' puis écriture puisque non-codé
Put #2, 1, buff
pnt = 0
' pnt : pointeur de position dans le code binaire de contrôle
' lecture du code de contrôle de codage
For i = 1 To lcode
ecode = Asc(Mid(code, i, 1))
bcode = dtob$(ecode)
' bcode: chaîne binaire du caractère de contrôle (cf. ctrl dans compresser1)
For j = 1 To 8
' enregistrement attendu par défaut à 1 octet
pnt = pnt + 1
enr = " "
If Mid(bcode, j, 1) = "0" Then
' si enregistrement non codé, lecture d'un octet
Get #1, , enr
Else
' sinon, lecture de la position dans le buffer
Get #1, , trouve
' puis de la taille du mot
Get #1, , lcur
' extraction du mot
enr = Mid(buff, trouve, lcur)
End If
' ajout du mot au buffer
buff = buff & enr
' écriture du mot
Put #2, , enr
If Len(buff) >= 32764 Then
' si la taille du buffer exède 32 ko - 4 octets
' re-définir le buffer à 16 Ko - 2 octets
buff = Right(buff, 16382)
End If
If pnt = limit Then
' si le pointeur est à la limite réelle du code binaire : sortie boucle
Exit For
End If
Next j
If pnt = limit Then
' si le pointeur est à la limite réelle du code binaire : sortie
Exit For
End If
Next i
msg = "Taille générée: " & LTrim(Str(LOF(2)))
hr2 = Time
msg = msg & Chr(13) & "Vitesse : " & LTrim(Str(Int(LOF(2) / ((hr2 - hr1) * 100000)))) & " octets/seconde"
Close
End Sub
Function btod(x As String)
' btod = valeur décimale d'une chaine binaire
' fonction Binary TO Decimal
nn = 0: xx = x: nx = 0
Do While Len(xx) > 0
nn = nn + Val(Right(xx, 1)) * (2 ^ nx)
nx = nx + 1
xx = Left(xx, Len(xx) - 1)
Loop
btod = nn
End Function
Function dtob$(n As Integer)
' dtob$ = chaine binaire de 8 caractères
' fonction Decimal to Binary
nn = n: xx = ""
Do While nn > 0
xx = Format(nn Mod 2, "0") & xx
nn = nn 2
Loop
dtob$ = Right("00000000" & xx, 8)
End Function