Un petit programme simple qui permet de découper un fichier en morceaux (de taille choisie) puis de recoller les morceau pour retrouver le fichier original...
Source / Exemple :
- CLASSE SCRITCH/UNSCRITCH ***
Option Explicit
Const ENTETE = "Scritcher_______________________________________________________________________"
'entete
'position 15 : 3 octets (en string) : longueur du nom de fichier
'position 18 : nom du fichier
'position len(ENTETE)+1 : 3 octets (en string) : n° du scritch
'position len(ENTETE)+4 : 3 octets (en string) : total des scritchs
'
Dim TailleEntete As Integer
Private SizeFile As Long
Public Event ProgressScritch(OctetsScritched As Long, OctectsRemaning As Long, FilesScritched As Integer, FilesRemaning As Integer)
Public Event ProgressUnScritch(OctetsUnScritched As Long, OctectsRemaning As Long, FilesUnScritched As Integer, FilesRemaning As Integer)
Public Function GoUnScritch(ByVal FinalFile As String, FilesToUnScritch() As String, ErrMsg As String) As Boolean
Dim NumFich() As Integer
Dim FilePosi As Long
Dim Tampon1 As String * 1
Dim Tampon10 As String * 10
Dim Tampon100 As String * 100
Dim Tampon1000 As String * 1000
Dim Tampon10000 As String * 10000
Dim i As Integer
Dim WritePosi As Long
Dim ReadPosi As Long
Dim tmpEntete As String
Dim oRestant As Double
On Error GoTo err_GoUnscritch
Screen.MousePointer = vbHourglass
GoUnScritch = False
ReDim NumFich(0 To UBound(FilesToUnScritch))
NumFich(0) = FreeFile
TailleEntete = Len(ENTETE) + 6
Open FinalFile For Binary As NumFich(0)
WritePosi = 1
For i = 1 To UBound(FilesToUnScritch)
NumFich(i) = FreeFile
Open FilesToUnScritch(i) For Binary As NumFich(i)
ReadPosi = TailleEntete + 1
Do Until ReadPosi > TailleFichier(FilesToUnScritch(i))
oRestant = TailleFichier(FilesToUnScritch(i)) - ReadPosi
If oRestant > 2 Then oRestant = oRestant - 1
'oRestant = 1
Select Case oRestant
Case 0 To 9
Get NumFich(i), ReadPosi, Tampon1
Put NumFich(0), WritePosi, Tampon1
WritePosi = WritePosi + 1
ReadPosi = ReadPosi + 1
Case 10 To 99
Get NumFich(i), ReadPosi, Tampon10
Put NumFich(0), WritePosi, Tampon10
WritePosi = WritePosi + 10
ReadPosi = ReadPosi + 10
Case 100 To 999
Get NumFich(i), ReadPosi, Tampon100
Put NumFich(0), WritePosi, Tampon100
WritePosi = WritePosi + 100
ReadPosi = ReadPosi + 100
Case 1000 To 9999
Get NumFich(i), ReadPosi, Tampon1000
Put NumFich(0), WritePosi, Tampon1000
WritePosi = WritePosi + 1000
ReadPosi = ReadPosi + 1000
Case Else
Get NumFich(i), ReadPosi, Tampon10000
Put NumFich(0), WritePosi, Tampon10000
WritePosi = WritePosi + 10000
ReadPosi = ReadPosi + 10000
End Select
RaiseEvent ProgressUnScritch(WritePosi, 0, i, UBound(FilesToUnScritch))
Loop
Next i
For i = 0 To UBound(FilesToUnScritch)
Close NumFich(i)
Next i
GoUnScritch = True
ErrMsg = "Ok"
Screen.MousePointer = vbDefault
Exit Function
err_GoUnscritch:
GoUnScritch = False
ErrMsg = "Une erreur est survenue durant l'opération"
Screen.MousePointer = vbDefault
End Function
Public Function GoScritch(FileToScritch As String, FileWhereScritch As String, PathWhereScritch As String, SizeScritch As Long, OutputFiles() As String, ErrMsg As String) As Boolean
Dim NumFich() As Integer
Dim tmpEntete As String
Dim FilePosi As Long
Dim WritePosi As Long
Dim FileToWrite As Integer
Dim Tampon1 As String * 1
Dim Tampon10 As String * 10
Dim Tampon100 As String * 100
Dim Tampon1000 As String * 1000
Dim Tampon10000 As String * 10000
Dim FileNameToScritch As String
Dim FileNameEntete As String
Dim i As Integer
Dim oRestant As Long
On Error GoTo err_GoScritch
Screen.MousePointer = vbHourglass
SizeFile = TailleFichier(FileToScritch)
TailleEntete = Len(ENTETE) + 6
GoScritch = False
If SizeScritch < (SizeFile / 1024) Then
'initialisation des fichiers
'ReDim NumFich(0 To (SizeFile / (SizeScritch * 1024 - TailleEntete) + 1))
ReDim NumFich(0 To Fix(SizeFile / (SizeScritch * 1024)) + 1)
ReDim OutputFiles(1 To Fix(SizeFile / (SizeScritch * 1024)) + 1)
NumFich(0) = FreeFile
Open FileToScritch For Binary As NumFich(0)
For i = 1 To UBound(NumFich)
NumFich(i) = FreeFile
'Open PathWhereScritch & "s_" & FileWhereScritch & "." & CStr(Format(i, "000")) For Binary As NumFich(i)
Open PathWhereScritch & FileWhereScritch & "_" & CStr(Format(i, "000")) & ".tch" For Binary As NumFich(i)
'écriture des entêtes
tmpEntete = ENTETE & Format(i, "000") & Format(UBound(NumFich), "000")
Put NumFich(i), 1, tmpEntete
FileNameToScritch = Dir(FileToScritch)
FileNameEntete = CStr(Format(Len(FileNameToScritch), "000")) & FileNameToScritch
Put NumFich(i), 15, FileNameEntete
Next i
'découpage du fichier
FilePosi = 1
FileToWrite = FilePosi \ (SizeScritch * 1024 - TailleEntete) + 1
Do Until FilePosi > SizeFile
'octets restant à écrire dans le fichier courant
oRestant = (SizeScritch * 1024 - TailleEntete) - ((FilePosi - 1) - ((FileToWrite - 1) * (SizeScritch * 1024 - TailleEntete)))
If oRestant > 2 Then oRestant = oRestant - 1
'oRestant = 1
Select Case oRestant
Case 1 To 9
Get NumFich(0), FilePosi, Tampon1
WritePosi = FilePosi + TailleEntete - ((FileToWrite - 1) * (SizeScritch * 1024 - TailleEntete))
Put NumFich(FileToWrite), WritePosi, Tampon1
FileToWrite = FilePosi \ (SizeScritch * 1024 - TailleEntete) + 1
FilePosi = FilePosi + 1
Case 10 To 99
Get NumFich(0), FilePosi, Tampon10
WritePosi = FilePosi + TailleEntete - ((FileToWrite - 1) * (SizeScritch * 1024 - TailleEntete))
Put NumFich(FileToWrite), WritePosi, Tampon10
FileToWrite = FilePosi \ (SizeScritch * 1024 - TailleEntete) + 1
FilePosi = FilePosi + 10
Case 100 To 999
Get NumFich(0), FilePosi, Tampon100
WritePosi = FilePosi + TailleEntete - ((FileToWrite - 1) * (SizeScritch * 1024 - TailleEntete))
Put NumFich(FileToWrite), WritePosi, Tampon100
FileToWrite = FilePosi \ (SizeScritch * 1024 - TailleEntete) + 1
FilePosi = FilePosi + 100
Case 1000 To 9999
Get NumFich(0), FilePosi, Tampon1000
WritePosi = FilePosi + TailleEntete - ((FileToWrite - 1) * (SizeScritch * 1024 - TailleEntete))
Put NumFich(FileToWrite), WritePosi, Tampon1000
FileToWrite = FilePosi \ (SizeScritch * 1024 - TailleEntete) + 1
FilePosi = FilePosi + 1000
Case Else
Get NumFich(0), FilePosi, Tampon10000
WritePosi = FilePosi + TailleEntete - ((FileToWrite - 1) * (SizeScritch * 1024 - TailleEntete))
Put NumFich(FileToWrite), WritePosi, Tampon10000
FileToWrite = FilePosi \ (SizeScritch * 1024 - TailleEntete) + 1
FilePosi = FilePosi + 10000
End Select
RaiseEvent ProgressScritch(FilePosi, SizeFile, FileToWrite, UBound(NumFich))
Loop
'fermeture des fichiers
For i = 0 To UBound(NumFich)
Close NumFich(i)
Next i
GoScritch = True
Else
'fichier trop petit
ErrMsg = "La taille du fichier source est inférieure la taille du 'Scritch' demandée..."
GoScritch = False
End If
Screen.MousePointer = vbDefault
Exit Function
err_GoScritch:
GoScritch = False
ErrMsg = "Une erreur est survenue!!!"
Screen.MousePointer = vbDefault
End Function
Public Function InfoFileScritch(PathFile As String, FileName As String, ScritchNumber As Integer, ScritchTotal As Integer) As Boolean
Dim NumFich As Integer
Dim Tampon As String * 50
Dim Tampon2 As String * 3
Dim Temp As Integer
On Error GoTo err_InfoFileScritch
NumFich = FreeFile
Open PathFile For Binary As NumFich
'nom de fichier
Get NumFich, 15, Tampon
Temp = Val(Mid(Tampon, 1, 3))
FileName = Mid(Tampon, 4, Temp)
'numero de scritch
Get NumFich, Len(ENTETE) + 1, Tampon2
ScritchNumber = Val(Tampon2)
'total scritch
Get NumFich, Len(ENTETE) + 4, Tampon2
ScritchTotal = Val(Tampon2)
Close NumFich
If FileName = "" Or ScritchNumber = 0 Or ScritchTotal = 0 Or ScritchNumber > ScritchTotal Then
InfoFileScritch = False
Else
InfoFileScritch = True
End If
Exit Function
err_InfoFileScritch:
InfoFileScritch = False
End Function
'************************
Private Function TailleFichier(NomFichier As String) As Long
Dim Fs As Object
Dim f As Object
On Error GoTo err_TailleFichier
Set Fs = CreateObject("Scripting.FileSystemObject")
Set f = Fs.getfile(NomFichier)
TailleFichier = f.Size
Exit Function
err_TailleFichier:
TailleFichier = 0
End Function
Private Function Char2Hexa(Valeur As String) As String
Dim t As Integer
t = Asc(Valeur)
Char2Hexa = Hex(t)
End Function
Private Function Hexa2String(Valeur As String) As String
Hexa2String = Chr(Val("&H" & Valeur))
End Function
Conclusion :
Deux onglets, un pour le découpage (Scritchage) et un pour le recollage (Unscritchage)...
Dans le deuxième onglet, le choix de n'importe quel fichier découpé permet au programme de retrouver tous les autres (s'il sont dans le même répertoire, bien sûr)
Un bouton permet d'effacer d'un coup tous les fichiers découpés après la restoration du fichier original
NOTE : Il y a une restriction sur la longueur de nom de fichier source (au delà de cinquante caractère, cela ne fonctionne plus)
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.