COMPRÉSSION / DÉCOMPRÉSSION

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