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...
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.