Compréssion / décompréssion

Commenter

Contenu du snippet

Voila encore une autre solution pour compréssé

Source / Exemple : 


Dans un module appelé : modLZW

Option Explicit
'
' Module de compression/décompression (Méthode LZW)
' 21/02/1999 [ Pied-vif ]
'

' Taille des mots à lire
Public BITCHAR As Long
' Taille des mots du dictionnaire
Public BITIND As Long
' Taille d'un long en binaire
Private Const LONGMOT = 32
Private lgDicoMin As Long
Private lgMaxDico As Long

' Taille du dictionnaire courant. Sa taille ne doit
' pas dépasser 2^BITIND
Private lgDictionnaire As Long
' Dictionnaire de compression/décompression
Private Dictionnaire() As String

' Handle du fichier à (dé)compresser
Private inFIn As Integer
' Handle du fichier résultat
Private inFOut As Integer

' Longueur du fichier source
Private lgLenF As Long
' Nombre d'éléments lus
Private lgNbLu As Long
' Nombre d'éléments écrits
Private lgNbEc
' Variable pour boucle For...Next
Private lgFor As Long

' Buffer de lecture
Private stReadBuffer As String
' Buffer d'écriture
Private stWriteBuffer As String
Private Sub CreationDico()
' Création du dictionnaire de base pour la compression/décompression
lgDicoMin = (2 ^ BITCHAR) - 1
lgDictionnaire = (2 ^ BITCHAR) - 1
ReDim Dictionnaire(lgDictionnaire) As String
For lgFor = 0 To lgDictionnaire
    Dictionnaire(lgFor) = DecToBin(lgFor, BITCHAR)
Next lgFor
lgMaxDico = 2 ^ BITIND
ReDim Preserve Dictionnaire(lgMaxDico - 1) As String
End Sub
Public Function DecToBin(lgNbDec As Long, lgBase As Long) As String
' Transforme un décimal en binaire
' La fonction complète avec des 0 (ou des 1 si négatif) en fonction de BITCHAR
' Retourne le résultat sous forme de chaîne
Dim stResultat As String
Dim lgDec As Long, lgK As Long
If lgNbDec < 0 Then lgK = 1
lgDec = Abs(lgNbDec)
Do While lgDec <> 0
    stResultat = (lgDec + lgK) Mod 2 & stResultat
' Divisions successives par 2, pour obtenir le nombre binaire
    lgDec = lgDec \ 2
Loop
DecToBin = Right$(String$(lgBase, CStr(lgK)) & stResultat, lgBase)
End Function

Public Function BinToDec(stNbBin As String) As Long
' Transforme un binaire en décimal
Dim lgLen As Long
Dim dlResultat As Double, lgDeux As Double
Dim stTmp As String
lgLen = Len(stNbBin)
stTmp = StrReverse(stNbBin)
lgDeux = 1
For lgFor = 1 To lgLen
    dlResultat = dlResultat + CLng(Mid$(stTmp, lgFor, 1)) * lgDeux
    lgDeux = lgDeux * 2
Next lgFor
If dlResultat > 2147483647 Then
    BinToDec = dlResultat - 4294967295#
Else
    BinToDec = dlResultat
End If
End Function
Private Function InDico(stString As String) As Long
' Regarde si la chaîne 'stString' se trouve dans le dictionnaire
' Retourne sa position si la chaîne est trouvée, sinon -1
Dim lgDeb As Long
If Len(stString) > BITCHAR Then lgDeb = lgDicoMin
For lgFor = lgDeb To lgDictionnaire
    If Dictionnaire(lgFor) = stString Then
        InDico = lgFor
        Exit Function
    End If
Next lgFor
InDico = -1
End Function
Public Sub Start(blCompress As Boolean, stFileIn As String, stFileOut As String)
Dim lgTmp As Long
' Création du dictionnaire
Call CreationDico

' Initialisation des variables d'avancement
lgLenF = FileLen(stFileIn)
lgNbLu = 0
lgNbEc = 0

inFIn = FreeFile
' Ouverture du fichier d'entrée
Open stFileIn For Random Access Read As inFIn Len = Len(lgTmp)
inFOut = FreeFile
' Ouverture du fichier résultat
Open stFileOut For Random Access Write As inFOut Len = Len(lgTmp)

' Initialisation des buffers de lecture et écriture
stReadBuffer = vbNullString
stWriteBuffer = vbNullString

If blCompress Then
' Appel de la procédure de compression
    Call LZW
Else
' Appel de la procédure de décompression
    Call DeLZW
End If

' Fermeture des fichiers
Close inFIn
Close inFOut

End Sub
Public Function LireBIT(lgBase As Long) As String
' Lit le prochain élément de longueur 'lgBase' dans le fichier d'entrée
Dim lgTmp As Long
Dim stResultat As String

Do While Len(stReadBuffer) < 200000 And Not EOF(inFIn)
    Get inFIn, , lgTmp

' Un long fait 4 octets (donc lgNbLu + 4)
    lgNbLu = lgNbLu + 4
    frmLZW.lblInfo1.Caption = "Lu : " & lgNbLu & " / " & lgLenF
    DoEvents

' Augmente le buffer de lecture avec l'élément qui vient d'être lu
    stReadBuffer = DecToBin(lgTmp, LONGMOT) & stReadBuffer
Loop
stResultat = Right$(stReadBuffer, lgBase)
' ici plantage quand streadbuffer < lgbase !!
If Len(stReadBuffer) - lgBase < 0 Then
    stReadBuffer = vbNullString
Else
    stReadBuffer = Left$(stReadBuffer, Len(stReadBuffer) - lgBase)
End If
LireBIT = stResultat
End Function
Public Sub EcrireBIT(stBitIndice As String)
' Ecrit l'élément 'Indice' du dictionnaire sous la base 'lgBase' dans le fichier de résultat de la compression
Dim lgTmp As Long
Dim lgFor As Long
' Augmente le buffer d'écriture avec la chaîne stBitIndice
stWriteBuffer = stBitIndice & stWriteBuffer
' Dès que la chaîne fait au moins 32 caractère (la taille d'un binaire long)
' on en convertit un morceau pour l'ajouter au fichier résultat
Do While Len(stWriteBuffer) >= LONGMOT
' Conversion Binaire vers Long
    lgTmp = BinToDec(Right$(stWriteBuffer, LONGMOT))
' Ecriture dans le fichier
    Put inFOut, , lgTmp
    
' Un long fait 4 octets (donc lgNbEc + 4)
    lgNbEc = lgNbEc + 4
    frmLZW.lblInfo2.Caption = "Ecrit : " & lgNbEc

' On diminue la buffer d'écriture, de la chaîne qu'on vient d'ajouter
    stWriteBuffer = Left$(stWriteBuffer, Len(stWriteBuffer) - LONGMOT)
Loop
End Sub
Public Sub LZW()
' Procédure principale de compression
Dim lgChaine As Long
Dim stCourant As String
Dim stCarTmp As String
stCourant = LireBIT(BITCHAR)
Do While Not EOF(inFIn) Or stReadBuffer <> vbNullString
    stCarTmp = LireBIT(BITCHAR)
    If InDico(stCarTmp + stCourant) > -1 Then
        stCourant = stCarTmp + stCourant
    Else
        Call EcrireBIT(DecToBin(InDico(stCourant), BITIND))
' Augmente le dictionnaire
        lgDictionnaire = lgDictionnaire + 1
        If lgDictionnaire Mod 100 = 0 Then frmLZW.lblInfo3.Caption = "Taille Dictionnaire : " & lgDictionnaire & " (" & lgMaxDico & ")"
        Dictionnaire(lgDictionnaire) = stCarTmp + stCourant
        stCourant = stCarTmp
        DoEvents
    End If
Loop
Call EcrireBIT(DecToBin(InDico(stCourant), BITIND))
' Ecriture du bout de chaîne restant
If stWriteBuffer <> vbNullString Then     ' Taille d'un élément de type long
    lgChaine = BinToDec(Right$(stWriteBuffer, LONGMOT))
    Put inFOut, , lgChaine
End If
End Sub
Public Function DeLZW()
' Procédure de décompression
Dim stCode As String
Dim lgAvance As Long
Dim stOld As String
Dim lgCourant As Long
Dim stCarTmp As String
Dim stCourant As String
' Initialisation de la lecture
stCode = LireBIT(BITIND)
Call EcrireBIT(Dictionnaire(BinToDec(stCode)))
stOld = stCode
Do While Not EOF(inFIn) Or stReadBuffer <> vbNullString
    stCode = LireBIT(BITIND)
    stCourant = Dictionnaire(BinToDec(stOld))
    If BinToDec(stCode) <= lgDictionnaire Then
        stCarTmp = Right$(Dictionnaire(BinToDec(stCode)), BITCHAR)
    Else
        stCarTmp = Right$(stCourant, BITCHAR)
    End If
' Augmente le dictionnaire
    lgDictionnaire = lgDictionnaire + 1
    If lgDictionnaire Mod 100 = 0 Then frmLZW.lblInfo3.Caption = "Taille Dictionnaire : " & lgDictionnaire & " (" & lgMaxDico & ")"
    Dictionnaire(lgDictionnaire) = stCarTmp + stCourant
    Call EcrireBIT(Dictionnaire(BinToDec(stCode)))
    stOld = stCode
    DoEvents
Loop
End Function

Dans une form appelé : frmLZW

Private Sub cmdGo_Click()
' Lance l'opération de compression/décompression

' Vérifie que le fichier source existe
If Dir(txtSource.Text) = vbNullString Then
    MsgBox "Le fichier source n'existe pas!", vbInformation, "Données incorrectes"
    txtSource.SetFocus
    Exit Sub
End If
' Vérifie que le fichier résultat n'existe pas
If Dir(txtResultat.Text) <> vbNullString Then
    MsgBox "Le fichier résultat existe déjà!", vbInformation, "Données incorrectes"
    txtResultat.SetFocus
    Exit Sub
End If

BITCHAR = CLng(txtBITCHAR.Text)
BITIND = CLng(txtBITIND.Text)

lblInfo4.Caption = "Début : " & Time
If optChoix(0).Value Then
' Lance la compression
    Call Start(True, txtSource.Text, txtResultat.Text)
Else
' Lance la décompression
    Call Start(False, txtSource.Text, txtResultat.Text)
End If
lblInfo4.Caption = lblInfo4.Caption & "/ Fin : " & Time
End Sub

Private Sub cmdQuitter_Click()
' Pour Quitter l'application
Unload Me
End Sub

Private Sub cmdSource_Click()
' Choix du fichier source, affichage de la fenêtre d'ouverture d'un
' fichier avec le contrôle CommonDialog
cdgFichier.DialogTitle = "Choix d'un fichier source"
cdgFichier.Flags = cdlOFNExplorer Or cdlOFNFileMustExist Or _
                   cdlOFNLongNames Or cdlOFNPathMustExist Or cdlOFNHideReadOnly
cdgFichier.CancelError = False
cdgFichier.Filter = "Tous les fichiers (*.*)|*.*"
cdgFichier.ShowOpen
txtSource.Text = cdgFichier.FileName
If optChoix(0).Value Then
    txtResultat.Text = txtSource.Text & ".lvb"
Else
    txtResultat.Text = Left$(txtSource.Text, Len(txtSource.Text) - 4)
End If
End Sub

Private Sub Form_Load()
' Initialisation des zones de la fenêtre
txtSource.Text = vbNullString
txtResultat.Text = vbNullString
optChoix(0).Value = True
lblInfo1.Caption = vbNullString
lblInfo2.Caption = vbNullString
lblInfo3.Caption = vbNullString
lblInfo4.Caption = vbNullString
End Sub

Private Sub lblTmp_Click(Index As Integer)

End Sub

Private Sub optChoix_Click(Index As Integer)
' Change le nom du fichier résultat lorsque la méthode change
If txtSource.Text <> vbNullString Then
    If optChoix(0).Value Then
        txtResultat.Text = txtSource.Text & ".lvb"
    Else
        txtResultat.Text = Left$(txtSource.Text, Len(txtSource.Text) - 4)
    End If
End If
End Sub

Conclusion :


Pour le zip, maillé moi...

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 (youl46)