Fusionneur de fichiers

Commenter

Contenu du snippet

Ce code permet de fusionner plusieurs fichiers de la meme extension ensemble.
Le probleme (mineur) c que la taille du fichier fusionné correspond au taille de chaque fichiers incorporé ! donc cela ne px etre pas pratique ....
Au début c'etait pr faire un systeme de skin et en faite cela marche pr nimporte quels fichiers ! alors ...
Le code se trouve ds un module avec les 2 fonctions necessaires pr compacter et decompacter.
Merci a neojoce de mavoir aide a resoudre un pb o nvo du compacatge :)

Source / Exemple : 


'----------------------
'FONCTION DE COMPACTAGE
'----------------------
'tableau ou se trouve les chemins des fichiers a compacter
Public TabImage(1000) As String

Public Function Compacter(Skin_Chemin As String, Skin_Nom As String) As Boolean
Screen.MousePointer = 11
Compacter = False
If Len(Skin_Chemin) = 0 Then Exit Function
If Right(Skin_Chemin, 1) <> "\" Then Skin_Chemin = Skin_Chemin & "\"
Dim Skin_Fichier As String
Dim num As Integer
Dim Catalogue As String
Dim Taille As Double
Dim Taille_Max As Double
Dim Contenu As String
Dim Nb_Images_Max As Integer
Skin_Fichier = Skin_Chemin & Skin_Nom
Open Skin_Fichier For Output As #1: Close #1

'##########
Taille_Max = 1000000000 'Taille maximum des fichiers images ici 1Go (environ car 1Ko = 1024 octets)
Nb_Images_Max = 100     'Nombre de fichier maximum a integrer
'##########

DoEvents
On Error GoTo fin
Catalogue = ""
For num = 0 To Nb_Images_Max - 1
    If TabImage(num) = "" Then GoTo fin
    Open TabImage(num) For Binary As #1
        Taille = LOF(1)
    Close #1
    If Taille >= Taille_Max Then GoTo fin
    Catalogue = Catalogue & String$(Len(CStr(Taille_Max)) - 1 - Len(CStr(Taille)), "0") & CStr(Taille) & ":"
fin:
Next num
On Error GoTo 0
Catalogue = Catalogue & vbCrLf
DoEvents
On Error GoTo fino
Open Skin_Fichier For Binary As #1
    Put #1, , Catalogue
    For num = 0 To Nb_Images_Max - 1
        If TabImage(num) = "" Then GoTo fino
        Open TabImage(num) For Binary As #2
            Contenu = Space$(LOF(2))
            Taille = LOF(2)
            Get #2, , Contenu
        Close #2
        If Taille >= Taille_Max Then GoTo fino
        Put #1, , Contenu
fino:
    Next num
Close #1
On Error GoTo 0
DoEvents
Compacter = True
Screen.MousePointer = 0
End Function

'------------------------
'FONCTION DE DECOMPACTAGE
'------------------------

Public Function Decompacter(Images_Chemin As String, Skin_Fichier As String, Images_Extensions As String) As Boolean
On Error GoTo finop
Screen.MousePointer = 11
Decompacter = False
If Len(Skin_Fichier) = 0 Then Exit Function
If Len(Images_Extensions) = 0 Or Left(Images_Extensions, 1) <> "." Then Exit Function
If Len(Images_Chemin) = 0 Then Images_Chemin = App.Path
If Right(Images_Chemin, 1) <> "\" Then Images_Chemin = Images_Chemin & "\"
Dim num As Integer
Dim NumTaille As Double
Dim Catalogue As String
Dim Taille As Double
Dim Contenu As String
Dim pos As Integer
Dim curpos As Integer
Dim ImageNum As Integer
Dim tmp As String
Open Skin_Fichier For Input As #1
    Line Input #1, Catalogue
Close #1
num = Len(Catalogue) + 3
curpos = 1
pos = 0
ImageNum = 0
NumTaille = 0
Do
    pos = InStr(curpos, Catalogue, ":")
    If pos <> 0 Then
        tmp = Mid$(Catalogue, 1, pos - 1)
        Taille = Val(tmp)
        If pos < Len(Catalogue) Then
            Catalogue = Mid$(Catalogue, pos + 1)
        Else
            Catalogue = ""
        End If
        ImageNum = ImageNum + 1
        Open Images_Chemin & "Image" & CStr(ImageNum) & Images_Extensions For Binary As #1
            Open Skin_Fichier For Binary As #2
                Contenu = Space$(LOF(2))
                Get #2, , Contenu
            Close #2
            Contenu = Mid$(Contenu, num + NumTaille, Taille)
            Put #1, , Contenu
            Contenu = ""
            NumTaille = NumTaille + Taille
        Close #1
    End If
Loop Until pos = 0
finop:
Decompacter = True
Screen.MousePointer = 0
End Function

Conclusion :


pour compacter les fichiers:
--------------------------------
'Ici on définit touts les fichier ki seront incorporés dans le compactage
'ils doivent etre tous de la meme extension !
'ds la fonction compactage, vous avez la
'variable : Taille_Max = 1000000000
'cela vs permet de fixer la taille maximum des fichiers a integree
'la variable Nb_Images_Max = 100 vous permet de definir
'le nombre maximum de fichiers a integrer ds le compactage
'dans le tableau TabImage() vous mettez le chemin complet des fichiers a
'compacter :

TabImage(0) = ".\images_a_convertir\img1.bmp"
TabImage(1) = ".\images_a_convertir\img2.bmp"
TabImage(2) = ".\images_a_convertir\img3.bmp"
TabImage(3) = ".\images_a_convertir\img4.bmp"
.....
.....
chemin_du_fichier_a_créer = ".\"
nom_du_fichier_compacté = "package.mesh"
resultat = Compacter(chemin_du_fichier_a_créer , nom_du_fichier_compacté )

et pour decompacter un fichier:
------------------------------------

chemin_ou_seront_les_images_decompacté = ".\images_converties\"
chemin_du_fichier_compacter = ".\package.mesh"
extension_d_fichiers = ".bmp"
resultat = Decompacter(chemin_ou_seront_les_images_decompacté , chemin_du_fichier_compacter , extension_d_fichiers )

#########
voila en esperant que cela vs serve ....
allez @++
Lumesh

PS: pt etre un MAJ va arrivé avc la possibilité d'intégrer des fichiers de differentes extensions ...

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