Compression/décompression par fenêtrage

Commenter

Contenu du snippet

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

Source / Exemple : 


' 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

A voir également

S'inscrire maintenant

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.

Du même auteur (fricotin92)