UN EXEMPLE DE COMPRESSEUR DE FICHIERS

Public chemin
Public disque
' PROGRAMME DE COMPRESSION DE DONNEES
' VIENT GERARD (FRANCE)
' Prévu pour le disque C:
' CECI EST UN EXEMPLE MAIS IL FAUDRAIT AMELIORER LA COMPRESSION
' ET LA RAPIDITE DU PROGRAMME ....
' En decompression on met le resultat dans c:\temp
'
' prévoir un écran avec deux zones de texte
' une zone de saisie pour le nom du fichier compressé
' une zone liste (dir1) contenant les repertoires
' une zone liste (file1) contenant les fichiers du repertoire
' deux boutons radios pour chosir le disque (c ou d)
' deux boutons commandes pour compresser ou decompresser
'

Private Sub CommandButton1_Click()
'
If Len(Dir(text1.Text)) <> 0 Then
   Kill text1.Text
End If
Dim table(5000) As String, table2(5000) As Long, table3(255) As Long, table4(10) As String, table5(10) As Long, car As String, totalfichier As String, remplacement As String, cart As String, carr As String, resultat As String, ligne As String, ligne2 As String
Position = 1
tailletot = 0
For i = 0 To file1.ListCount - 1
   If file1.Selected(i) Then
      poslong = Position + 32
      Open chemin + file1.List(i) For Binary As 1
      taille = LOF(1)
      tailletot = tailletot + taille
      totalfichier = String(taille, " ")
      Get #1, 1, totalfichier
      Close 1
      Label2.Caption = "TRAITEMENT CHOIX " + file1.List(i) + " TAILLE EN OCTETS : " + Str(taille)
      blanc = String(128, " ")
      '
      ' on écrit le nombre de caractère disponibles pour la répétition
      '
      g = 1
      temp3 = ""
      Erase table, table2, table3, table4, table5
      pos = 1
      maxix = 0
      taille2 = taille + 1
      While pos > 0
         temp = Str(Int(g / taille * 100))
         If temp <> temp3 Then
            Label2.Caption = "TRAITEMENT LECTURE " + file1.List(i) + temp + "%"
            UserForm1.Repaint
            temp3 = temp
         End If
         fin = True
         mot = ""
         While fin
            car = Mid(totalfichier, pos, 1)
            pos = pos + 1
            mot = mot + car
            tp = Asc(car + " ")
            table3(tp) = table3(tp) + 1
            If Len(mot) = 4 Or car = "" Then fin = False
         Wend
         If pos > Len(totalfichier) Then pos = 0
         If pos > 0 Then
            If Len(mot) >= 2 Then
               trouve = False
               For h = 0 To maxix
                  If mot = table(h) Then
                     table2(h) = table2(h) + 1
                     h = maxix
                     trouve = True
                  End If
               Next h
               If trouve = False And maxix < 250 Then
                  maxix = maxix + 1
                  table(maxix) = mot
                  table2(maxix) = 1
               End If
            End If
            g = pos
         End If
      Wend
      '
      ' on tri determine les caracteres
      ' à répéter
      '
      tri = True
      While tri
         tri = False
         For g = 0 To maxix
            For h = g + 1 To maxix
               If table2(g) * Len(table(g)) < table2(h) * Len(table(h)) Then
                  tt1 = table(g)
                  tt2 = table2(g)
                  table(g) = table(h)
                  table2(g) = table2(h)
                  table(h) = tt1
                  table2(h) = tt2
                  tri = True
               End If
            Next h
         Next g
      Wend
      '
      ' tri des caracteres du moins vers le plus
      ' pour utiliser les  caracteres de repetitions qui apparaissent
      ' le moins dans le fichier
      '
      For g = 0 To 10
          table5(g) = 999999999#
      Next g
      For g = 0 To 255
         For h = 0 To 10
            If table5(h) > table3(g) Then
               table5(h) = table3(g)
               table4(h) = Chr(g)
               h = 10
            End If
         Next h
      Next g
      Open text1.Text For Binary As 2
      '
      ' on prepare les 4 octets de la longueur du fichier
      '
      ligne = MKL(0)
      Put #2, Position, ligne
      Position2 = Position
      Position = Position + 4
      '
      ' on ecrit le caractère de remplacement
      '
      ligne = table4(0)
      Put #2, Position, ligne
      Position = Position + 1
      '
      ' on ecrit la longueur du nom de fichie reel
      '
      ligne = Chr(Len(Trim(file1.List(i))))
      Put #2, Position, ligne
      Position = Position + 1
      '
      ' on ecrit le nom du fichier reel
      '
      ligne = Trim(file1.List(i))
      Put #2, Position, ligne
      Position = Position + Len(ligne)
      '
      ' on ecrit les occurences des chaines
      ' 1 caractere de repetition
      ' 1 caractere pour la longueur de la zone repete
      ' la zone repete
      '
      For g = 0 To 9
         mot = table(g)
         ligne = table4(g + 1)
         Put #2, Position, ligne
         Position = Position + 1
         ligne = Chr(Len(mot))
         Put #2, Position, ligne
         Position = Position + 1
         ligne = mot
         Put #2, Position, ligne
         Position = Position + Len(ligne)
      Next g
      g = 1
      carr = table4(0)
      Position3 = Position
      While g <= Len(totalfichier)
         cart = Mid(totalfichier, g, 1)
         temp = Str(Int(g / taille2 * 100))
         If temp <> temp3 Then
            Label2.Caption = "TRAITEMENT ECRITURE " + file1.List(i) + temp + "%"
            UserForm1.Repaint
            temp3 = temp
         End If
         For h = 0 To 9
            mot = table4(h + 1)
            If cart = mot Then
               ligne = carr + mot
               Put #2, Position, ligne
               Position = Position + 2
               g = g + 1
               h = 99
            Else
               mot = table(h)
               If mot <> "" Then
                  If Mid(totalfichier, g, Len(mot)) = mot Then
                     ligne = table4(h + 1)
                     Put #2, Position, ligne
                     Position = Position + 1
                     g = g + Len(mot)
                     h = 99
                  End If
               End If
            End If
         Next h
         If cart = carr Then
            ligne = carr + cart
            Put #2, Position, ligne
            Position = Position + 2
            g = g + 1
         Else
           If h < 99 Then
              ligne = cart
              Put #2, Position, ligne
              Position = Position + 1
              g = g + 1
           End If
         End If
      Wend
      ligne = MKL(Position - Position3)
      Put #2, Position2, ligne
      taillecomp = LOF(2)
      Close #2
      '
      ' on ecrit les caracteres de répétition
      '
      If taille > 0 Then Label2.Caption = file1.List(i) + "(" + Str(Int((Position - Position2) / Len(totalfichier) * 100)) + "%)"
   End If
Next i
MsgBox "OK TRAITEMENT TERMINE TAILE AVANT EN OCTETS" + Str(tailletot) + " TAILLE APRES " + Str(taillecomp) + "(" + Str(Int((taillecomp / tailletot) * 100)) + "%)"

End Sub

Private Sub CommandButton2_Click()
Dim zone As String
Dim tabler(10) As String, tablel(10) As Long, tablem(10) As String
Open text1.Text For Binary As 1
Position = 1
While Position <= LOF(1)
   zone = "xxxx"
   Get #1, Position, zone
   Position = Position + Len(zone)
   longueurc = CVL(zone)
   zone = "x"
   Get #1, Position, zone
   Position = Position + Len(zone)
   carr = zone
   Get #1, Position, zone
   Position = Position + Len(zone)
   lnom = Asc(zone)
   zone = String(lnom, " ")
   Get #1, Position, zone
   Position = Position + Len(zone)
   nomfic = zone
   For g = 1 To 10
      zone = "x"
      Get #1, Position, zone
      Position = Position + Len(zone)
      tabler(g) = zone
      Get #1, Position, zone
      Position = Position + Len(zone)
      tablel(g) = Asc(zone)
      zone = String(tablel(g), "x")
      Get #1, Position, zone
      Position = Position + Len(zone)
      tablem(g) = zone
   Next g
   '
   ' on remet le fichier dans temp
   '
   Label2.Caption = "TRAITEMENT DU FICHIER " + nomfic + Str(longueurc)
   UserForm1.Repaint
   Position2 = 1
   Open "c:\temp\" + nomfic For Binary As 2
   zone = "x"
   taille2 = longueurc + 1
   For g = 1 To longueurc
      Get #1, Position, zone
      Position = Position + Len(zone)
      temp = Str(Int(Position / taille2 * 100))
      If temp <> temp3 Then
         Label2.Caption = "TRAITEMENT DU FICHIER " + nomfic + temp + "%"
         UserForm1.Repaint
         temp3 = temp
      End If
      If zone = carr Then
         Get #1, Position, zone
         Position = Position + Len(zone)
         Put #2, Position2, zone
         Position2 = Position2 + Len(zone)
      Else
        trouve = False
        For h = 1 To 10
           If zone = tabler(h) Then
              Put #2, Position2, tablem(h)
              Position2 = Position2 + Len(tablem(h))
              trouve = True
              h = 10
           End If
        Next h
        If Not trouve Then
           Put #2, Position2, zone
           Position2 = Position2 + Len(zone)
        End If
      End If
   Next g
   Close #2
Wend
Close #1
MsgBox "TRAITEMENT TERMINE RESULTAT DANS C:\temp"
End Sub

Private Sub dir1_Change()

End Sub

Private Sub dir1_Click()
For i = 0 To dir1.ListCount - 1
   If dir1.Selected(i) Then
      chemin = chemin + dir1.List(i) + "\"
   End If
   
Next i

      dir1.Clear
      file1.Clear
      myname = Dir(chemin)
      nb = 1
      Do While myname <> ""   ' Commence la boucle.
      ' Ignore le répertoire courant et le répertoire
      ' contenant le répertoire courant.
      If myname <> "." And myname <> ".." Then

      ' Utilise une comparaison au niveau du bit pour
        ' vérifier que MyName est un répertoire.

            file1.AddItem (myname)
      End If
      myname = Dir    ' Extrait l'entrée suivante.
 Loop
 MyPath = chemin  ' Définit le chemin d'accès.
 ' Extrait la première entrée.
 myname = Dir(MyPath, vbDirectory)
 nb = 1
 Do While myname <> ""   ' Commence la boucle.
 
 If (GetAttr(MyPath & myname) _
             And vbDirectory) = vbDirectory Then
                            dir1.AddItem (myname)
 End If
    myname = Dir    ' Extrait l'entrée suivante.
 Loop
 UserForm1.Repaint
 
End Sub

Private Sub Label2_Click()

End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub ListBox2_Click()

End Sub

Private Sub OptionButton1_Click()
dir1.Clear
file1.Clear
chemin = "c:\"
myname = Dir(chemin)
nb = 1
Do While myname <> ""   ' Commence la boucle.
    ' Ignore le répertoire courant et le répertoire
    ' contenant le répertoire courant.
    If myname <> "." And myname <> ".." Then

' Utilise une comparaison au niveau du bit pour
        ' vérifier que MyName est un répertoire.

            file1.AddItem (myname)
    End If
    myname = Dir    ' Extrait l'entrée suivante.
Loop
MyPath = chemin
' Extrait la première entrée.
myname = Dir(MyPath, vbDirectory)
nb = 1
Do While myname <> ""   ' Commence la boucle.

If (GetAttr(MyPath & myname) _
            And vbDirectory) = vbDirectory Then
                            dir1.AddItem (myname)
End If
    myname = Dir    ' Extrait l'entrée suivante.
Loop
End Sub

Private Sub OptionButton2_Click()
dir1.Clear
file1.Clear
chemin = "d:\"
myname = Dir(chemin)
nb = 1
Do While myname <> ""   ' Commence la boucle.
    ' Ignore le répertoire courant et le répertoire
    ' contenant le répertoire courant.
    If myname <> "." And myname <> ".." Then

' Utilise une comparaison au niveau du bit pour
        ' vérifier que MyName est un répertoire.

            file1.AddItem (myname)
    End If
    myname = Dir    ' Extrait l'entrée suivante.
Loop
MyPath = chemin
' Extrait la première entrée.
myname = Dir(MyPath, vbDirectory)
nb = 1
Do While myname <> ""   ' Commence la boucle.

If (GetAttr(MyPath & myname) _
            And vbDirectory) = vbDirectory Then
                            dir1.AddItem (myname)
End If
    myname = Dir    ' Extrait l'entrée suivante.
Loop
End Sub

Private Sub UserForm_Activate()
'
' on travaille sur le disque c:
'
disque = "c:"
MyPath = disque + "\" ' Définit le chemin d'accès.
chemin = disque + "\"
' Extrait la première entrée.
myname = Dir(MyPath)
nb = 1
Do While myname <> ""   ' Commence la boucle.
    ' Ignore le répertoire courant et le répertoire
    ' contenant le répertoire courant.
    If myname <> "." And myname <> ".." Then

' Utilise une comparaison au niveau du bit pour
        ' vérifier que MyName est un répertoire.

            file1.AddItem (myname)
    End If
    myname = Dir    ' Extrait l'entrée suivante.
Loop
MyPath = disque + "\" ' Définit le chemin d'accès.
' Extrait la première entrée.
myname = Dir(MyPath, vbDirectory)
nb = 1
Do While myname <> ""   ' Commence la boucle.

If (GetAttr(MyPath & myname) _
            And vbDirectory) = vbDirectory Then
                            dir1.AddItem (myname)
End If
    myname = Dir    ' Extrait l'entrée suivante.
Loop
End Sub


Private Sub UserForm_Click()
End Sub

Private Sub Command1_Click()
End Sub



Function MKL(chiffre)
'
' sp pour transformer un nombre en 4 caractères
' Note : nombre entier et positif
'
Dim x1 As Long, x2 As Long, x3 As Long
x1 = 256# * 256# * 256#
x2 = 256# * 256#
x3 = 256#
chiffre2 = chiffre
a1$ = Chr(Int(chiffre2 / x1))
chiffre2 = chiffre2 - Asc(a1$) * x1
a2$ = Chr(Int(chiffre2 / x2))
chiffre2 = chiffre2 - Asc(a2$) * x2
a3$ = Chr(Int(chiffre2 / x3))
chiffre2 = chiffre2 - Asc(a3$) * x3
a4$ = Chr(Int(chiffre2))
MKL = a1$ + a2$ + a3$ + a4$

End Function

Function CVL(zone As String)
'
' sp pour transformer un nombre en 4 caractères
' Note : nombre entier et positif
'
Dim x1 As Long, x2 As Long, x3 As Long
x1 = 256# * 256# * 256#
x2 = 256# * 256#
x3 = 256#
CVL = Asc(Left(zone, 1)) * x1 + Asc(Mid(zone, 2, 1)) * x2 + Asc(Mid(zone, 3, 1)) * x3 + Asc(Right(zone, 1))
End Function