COUPEUR DE FICHIERS

Option Explicit
Private file_open, dir_out As String
Private ascii() As Variant

Private Sub CommandButton1_Click()
Dim o As MSComDlg.CommonDialog
Dim tmq, tmp As String
Dim i As Long
    'initialisation de l'objet
    Set o = Me.Controls.Add("MSComDlg.CommonDialog", "Essai")
    o.InitDir = App.Path
    o.Filter = "*|*.*"
    'Methode de l'objet
    o.ShowOpen
    file_open = o.FileName
    'ouvrir et reup si erreur le fichier exel
    'permet d'afficher une fenetre de sauvegarde
    'O.ShowSave
    'Debug.Print "SAUVE :"; O.FileName
    'Propiete
    'tmp = O.FileName
    Text1.Text = file_open
    Me.Controls.Remove ("Essai")
    Set o = Nothing
    
End Sub

Private Sub CommandButton2_Click()
Dim F As Object
Dim fs As Object
Dim fol As String
Dim i, j As Integer
'le $ sert a dire que string = dim a as string
Dim flagchoix&, msg$, racine&

'flagchoix = &H1&: msg = "Choissisez un dossier :"
'Set fs = CreateObject("Shell.Application")
'Set f = fs.BrowseForFolder(&H0&, msg, flagchoix)
'If Not f Is Nothing Then
'    If InStr(1, f.ParentFolder.parsename(f.Title).Path, ":", vbTextCompare) <> 0 Then
'    dir_out = f.ParentFolder.parsename(f.Title).Path
'    Text2 = dir_out
'    Else
'    MsgBox "Veuillez sélectionner un répertoire valide"
'    End If
'End If
flagchoix = &H1&: msg = "Select a folder :"
Set fs = CreateObject("Shell.Application")
Set F = fs.BrowseForFolder(&H0&, msg, flagchoix)
If Not F Is Nothing Then
    dir_out = F.self.Path
    Text2 = dir_out
Else
    MsgBox "Veuillez sélectionner un répertoire valide"
End If

End Sub

Private Sub Form_Load()
    Text3 = "1,44"
    file_open = ""
    dir_out = ""
    Call import_table_ascii
    'Text1 = "01-sweet and tangy.mp3"
    file_open = Text1
    'Text2 = "C:\Temp\Nouveau dossier"
    dir_out = Text2
End Sub

'Private Sub CommandButton5_Click()
'Dim taille_partie As Single, taille_fichier_o As Single, nb As Single, nb_partie As Single, tmp As Single
'Dim i As Long
'Dim fRandom As Random, fWriteRandom As Random
'Dim f
'Dim tp As FileSystemObject
'Dim temp As String
'If Text3.Text <> "" And IsNumeric(Text3.Text) And file_open <> "" And dir_out <> "" Then
'    taille_partie = CSng(Text3.Text) * 1024
'    Set tp = CreateObject("Scripting.FileSystemObject")
'    temp = Mid(tp.GetFileName(file_open), 1, Len(tp.GetFileName(file_open)) - 3)
'    Set f = tp.GetFile(file_open)
'    taille_fichier_o = f.Size
'    Set f = Nothing
'    Set tp = Nothing
'    'file random
'    Set fRandom = New Random
'    Set fWriteRandom = New Random
'    fRandom.OpenFile file_open
'    fRandom.SeekAbsolute 0, 1     ' Seeks 2 bytes (0*2^32 + 2) = 1 character.
''    f.SeekRelative -2       ' Seeks backward 1 character.
'    nb_partie = taille_fichier_o / taille_partie
'    nb = 0
'    tmp = 0
'    fWriteRandom.OpenFile dir_out & "\" & file_open & "." & nb
'    While nb <> taille_fichier_o - 1
'        temp = fRandom.ReadBytes(1)
'        If taille_fichier_o Mod taille_partie And nb <> 0 Then
'            tmp = tmp + 1
'            fWriteRandom.CloseFile
'            fWriteRandom.SeekAbsolute 0, 8
'            fWriteRandom.SeekAbsolute 0, 8
'        End If
'        fWriteRandom.WriteBytes temp
'        nb = nb + taille_fichier_o
'    Wend
'End If
'End Sub
Private Sub CommandButton5_Click()
Dim taille_partie, taille_fichier_o, nb As Long
Dim tp As FileSystemObject
Dim F
Dim j, k, L As Integer
Dim Temp, new_file, ext_name, txt As String
Dim Data As Variant
Dim datawrite() As Byte
Dim fRandom As Random, fWriteRandom As Random
On Error GoTo error

If Text3.Text <> "" And IsNumeric(Text3.Text) And file_open <> "" And dir_out <> "" Then
    'test si il n'ya que 2 decimale
    If Round(CDbl(Text3.Text), 2) = CDbl(Text3.Text) Then
        taille_partie = CSng(Text3.Text) * 1024 * 1024
        Set tp = CreateObject("Scripting.FileSystemObject")
        Temp = Mid(tp.GetFileName(file_open), 1, Len(tp.GetFileName(file_open)) - 3)
        ext_name = tp.GetExtensionName(file_open)
        Set F = tp.GetFile(file_open)
        taille_fichier_o = F.Size
        If taille_fichier_o > taille_partie Then
            j = Fix(taille_fichier_o / taille_partie) 'donne le nombre de partie entière
            'couper le fichier
            new_file = dir_out & "\" & Temp
            k = 0
            Set fRandom = New Random
            Set fWriteRandom = New Random
            'fRandom.CloseFile
            fRandom.OpenFile (F.Path)
            While k <> j
'                If k * taille_partie < 2147483647 Then
'                    fRandom.SeekAbsolute k * taille_partie, (k + 1) * taille_partie
'                Else
'                    fRandom.SeekAbsolute -2147483647 - k * taille_partie - 2147483647, (k + 1) * taille_partie
'                End If
                Data = fRandom.ReadBytes(taille_partie)
                fWriteRandom.OpenFile new_file & k
                datawrite = Data
                fWriteRandom.WriteBytes datawrite()
                fWriteRandom.CloseFile
                k = k + 1
            Wend
'            If k * taille_partie < 2147483647 Then
'                fRandom.SeekAbsolute k * taille_partie, (k + 1) * taille_partie
'            Else
'                fRandom.SeekAbsolute -2147483647 - k * taille_partie - 2147483647, (k + 1) * taille_partie
'            End If
            If k * taille_partie <> taille_fichier_o Then
'            fRandom.SeekAbsolute k * taille_partie, taille_fichier_o
            Data = fRandom.ReadBytes(taille_fichier_o - k * taille_partie)
            fWriteRandom.OpenFile new_file & k
            datawrite = Data
            fWriteRandom.WriteBytes datawrite()
            fWriteRandom.CloseFile
            End If
'            Open file_open For Binary Access Read As #1
'            Do While Not EOF(1)
'                If taille_fichier_mo <> taille_partie * j And k = j Then
'                    Data = ""
'                    Data = String(f.Size - j * Fix(taille_partie * 1024 * 1024), " ")
'                End If
'                If k <= j Then
'                Open new_file & k For Binary Access Write As #2
'                Get #1, , Data
'                Put #2, , Data
'                Close #2
'                k = k + 1
'                Else
'                GoTo 1:
'                End If
'            Loop
'1:
'            Close #1
            'cration du .bat copy all partie to ancien nom fichier
            Open new_file & "bat" For Output As #1
            'Print #1, "Echo off"
            txt = ""
            For L = 0 To k
                txt = txt & " + """ & Temp & L & """"
            Next L
            txt = txt & " """ & Temp & ext_name & """"
            'Print #1, "Copy /b " & Mid(txt, 4, Len(txt) - 3)
            'Print #1, "Echo ""Fichier reconstitue"""
            'Print #1, "pause"
            txt = "Echo off" & Chr(10) & _
                  "Copy /b " & Mid(txt, 4, Len(txt) - 3) & Chr(10) & _
                  "Echo ""Fichier reconstitué""" & Chr(10) & _
                  "pause"
                Call replace_str(txt)
                Print #1, txt
            Close #1
            If taille_fichier_o <> taille_partie * j Then
            nb = j + 1
            Else
            nb = j
            End If
            MsgBox "Travail terminé : " & nb & " Parties crées pour " & Round((taille_fichier_o / 1024) / 1024, 2) & " Mo"
            Set F = Nothing
            Set tp = Nothing
        Else
            MsgBox ("La taille des parties est inférieur ou egale a celle du fichier")
        End If
    Else
        MsgBox ("La taille en Mo ne doit contenir que 2 chiffre apres la virgule")
    End If
Else
    MsgBox "Veuillez Renseigner tous les champs. Attention : " & Chr(13) & "utiliser une virgule pour la taille (Ex : 1,44)."
End If
Set fRandom = Nothing
Set fWriteRandom = Nothing
Exit Sub
error:
MsgBox Err.Number & " " & Err.Description
Set fRandom = Nothing
Set fWriteRandom = Nothing
End Sub

'old
'Private Sub CommandButton5_Click()
'Dim taille_partie, taille_fichier_mo, nb As Double
'Dim tp As FileSystemObject
'Dim f
'Dim j, k, L As Integer
'Dim temp, new_file, ext_name, txt As String
'Dim Data As String
'
'If Text3.Text <> "" And IsNumeric(Text3.Text) And file_open <> "" And dir_out <> "" Then
'    'test si il n'ya que 2 decimale
'    If Round(CDbl(Text3.Text), 2) = CDbl(Text3.Text) Then
'
'        taille_partie = CSng(Text3.Text)
'        Set tp = CreateObject("Scripting.FileSystemObject")
'        temp = Mid(tp.GetFileName(file_open), 1, Len(tp.GetFileName(file_open)) - 3)
'        ext_name = tp.GetExtensionName(file_open)
'        Set f = tp.GetFile(file_open)
'        taille_fichier_mo = Round(CDbl(CDbl(f.Size / 1024) / 1024), 2)
'        If taille_fichier_mo > taille_partie Then
'            j = Fix(taille_fichier_mo / taille_partie) 'donne le nombre de partie entière
'            'couper le fichier
'            new_file = dir_out & "\" & temp
'            Data = String(Fix(taille_partie * 1024 * 1024), " ")
'            k = 0
'            Open file_open For Binary Access Read As #1
'            Do While Not EOF(1)
'                If taille_fichier_mo <> taille_partie * j And k = j Then
'                    Data = ""
'                    Data = String(f.Size - j * Fix(taille_partie * 1024 * 1024), " ")
'                End If
'                If k <= j Then
'                Open new_file & k For Binary Access Write As #2
'                Get #1, , Data
'                Put #2, , Data
'                Close #2
'                k = k + 1
'                Else
'                GoTo 1:
'                End If
'            Loop
'1:
'            Close #1
'            'cration du .bat copy all partie to ancien nom fichier
'            Open new_file & "bat" For Output As #1
'            'Print #1, "Echo off"
'            txt = ""
'            For L = 0 To k - 1
'                txt = txt & " + """ & temp & L & """"
'            Next L
'            txt = txt & " """ & temp & ext_name & """"
'            'Print #1, "Copy /b " & Mid(txt, 4, Len(txt) - 3)
'            'Print #1, "Echo ""Fichier reconstitue"""
'            'Print #1, "pause"
'            txt = "Echo off" & Chr(10) & _
'                  "Copy /b " & Mid(txt, 4, Len(txt) - 3) & Chr(10) & _
'                  "Echo ""Fichier reconstitué""" & Chr(10) & _
'                  "pause"
'                Call replace_str(txt)
'                Print #1, txt
'            Close #1
'            If taille_fichier_mo <> taille_partie * j Then
'            nb = j + 1
'            Else
'            nb = j
'            End If
'            MsgBox "Travail terminé : " & nb & " Parties crées pour " & taille_fichier_mo & " Mo"
'            Set f = Nothing
'            Set tp = Nothing
'        Else
'            MsgBox ("La taille des parties est inférieur ou egale a celle du fichier")
'        End If
'    Else
'        MsgBox ("La taille en Mo ne doit contenir que 2 chiffre apres la virgule")
'    End If
'Else
'    MsgBox "Veuillez Renseigner tous les champs. Attention : " & Chr(13) & "utiliser une virgule pour la taille (Ex : 1,44)."
'End If
'End Sub

Public Sub import_table_ascii()
Dim txt As String
Dim i, j As Integer
ReDim ascii(127, 1)
Open App.Path & "\table.txt" For Input As #1
i = 0
Do While Not EOF(1)
Input #1, txt
j = InStr(1, txt, Chr(9), vbTextCompare)
ascii(i, 0) = Mid(txt, 1, j - 1)
ascii(i, 1) = Mid(txt, j + 1, Len(txt) - j)
i = i + 1
Loop
Close #1
End Sub

Public Sub replace_str(ByRef txt As String)
Dim i, t As Long
For i = 1 To Len(txt)
    t = Asc(Mid(txt, i, 1))
    If t > 127 Then
        If IsNumeric(ascii(t - 128, 1)) Then
        Mid(txt, i, 1) = Chr(ascii(t - 128, 1))
        End If
    End If
Next i
End Sub

Télécharger le zip