Transfert

Sub Transfert()

    Dim Fso, WShell
    Dim RepSource, RepCible, Folder
    Dim RepSourcePath, RepCiblePath
    Dim Volume
    Dim Deplace, Message
    Dim Existe_mais_Diff, Pas_Trouve
    Dim Existe_mais_Diff_Name, Pas_Trouve_Name
    Dim File, Fic_Cible
    Dim nbFic
    Dim i, j, trouve, Erreur_Rep
    Dim Tab_Rep(30) 'As String
    Dim Tab_Jpg(30) 'As Integer
    Dim Tab_Mov(30) 'As Integer

    Set Fso = CreateObject("scripting.FileSystemObject")
    Set WShell = Wscript.CreateObject("WScript.Shell")
 
    ' Rpertoire de destination des fichiers (ne pas oublier de terminer par un "\")
    ' Exemple : RepCiblePath = "E:\Mes Documents\Mes images\Photos\Transfert\"
	RepCiblePath = "Mettre ici votre rpertoire de destination"

	' Ne pas modifier le test si dessous qui sert uniquement  verifier
	' si la variable RepCiblePath a bien t modifie
	If RepCiblePath = "Mettre ici votre rpertoire de destination" Then
		MsgBox "Vous n'avez pas modifi la variable RepCiblePath (ligne 24) en y mettant le rpertoire de destination des fichiers !", vbCritical, "Erreur"
        Exit Sub
    End If

    Set RepSource = Fso.GetFolder("DCIM\")
    Set RepCible = Fso.GetFolder(RepCiblePath)

    On Error Resume Next

    ' Si 76 c'est que le rpertoire cible n'existe pas (peut-tre pas sur le bon ordi) ==> On sort
    If Err.Number = "76" Then
        Exit Sub
    End If

    i = 0
    trouve = 0
    ' On recherche le(s) rpertoire(s) de stockage des photos (gner par l'APN)
    For Each Folder In RepSource.SubFolders
        If Folder.Files.Count > 0 Then
            For Each File In Folder.Files
                If LCase(Right(File.Name, 4)) = ".jpg" Or LCase(Right(File.Name, 4)) = ".mov" Then
                    If LCase(Right(File.Name, 4)) = ".jpg" Then
                        Tab_Jpg(i) = Tab_Jpg(i) + 1
                    Else
                        Tab_Mov(i) = Tab_Mov(i) + 1
                    End If
                    If Tab_Rep(i) = "" And trouve = 0 Then
                        Tab_Rep(i) = Folder.Path
                        trouve = 1
                    End If
                    nbFic = nbFic + 1
                    Volume = Volume + Round(File.Size / 1024 / 1024, 1)
                End If
            Next
            trouve = 0
        End If
		i = i + 1
    Next

    ' Calcul de la date pour gnration du rpertoire cible
    Dim jour, mois, annee, la_date
    jour = Day(Date)
    If jour < 10 Then jour = "0" & jour
    mois = Month(Date)
    If mois < 10 Then mois = "0" & mois
    annee = Year(Date)
    la_date = annee & "." & mois & "." & jour

    Err = 0

    On Error GoTo 0

    ' Comptage nombre de fichiers  transferer, si pas de fichier ==> On sort
    If nbFic = 0 Then
        MsgBox "La carte est vide, il n'y a pas de fichier  transferer.", vbExclamation, "Erreur"
        Exit Sub
    End If

    If Volume > Round(RepCible.Drive.freespace / 1024 / 1024, 1) Then
        MsgBox "Espace insuffisant, " & Volume & " Mo  transferer," & vbNewLine & "alors que le lecteur source n'a que " & Round(RepCible.Drive.freespace / 1024 / 1024, 1) & " Mo de libre.", vbCritical + vbOKOnly, "Espace disque insuffisant"
        Exit Sub
    End If

    ' Il serait temps de se demander si l'utilisateur veut bien copier les fichiers
    Select Case MsgBox("Voulez-vous tranferer les " & nbFic & " fichiers (" & Volume & " Mo) ?", vbQuestion + vbYesNo, "Transfert de fichiers")
    ' Si Oui, on continue, sinon ==> on sort
    Case vbNo
        Exit Sub
    End Select

    Err = 0
    
    On Error Resume Next
    ' On regarde si le rpertoire cible "dat" existe dj
    Set RepCible = Fso.GetFolder(RepCiblePath & la_date)

    ' S"il n'existe pas, on le cr
    If Err.Number = "76" Then
        Err.Clear
        Set RepCible = Nothing
        Set RepCible = Fso.CreateFolder(RepCiblePath & la_date)
    End If

    ' Si Err.Number ="76", alors visiblement on ne peut pas le crr ==> On sort
    If Err.Number = "76" Then
        MsgBox "Le rpertoire cible n'existe pas !", vbCritical, "Erreur"
        Exit Sub
    End If

    ' Ay, on copie les fichiers vers le rpertoire de destination "dat"
    For j = 0 To i - 1
        ' Ce sera notre rpertoire source
        RepSourcePath = Tab_Rep(j)
        Set RepSource = Fso.GetFolder(RepSourcePath & "\")
        ' S'il y a des photos dans le rpertoire source, on les transfert
        If Tab_Jpg(j) > 0 Then
            Deplace = WShell.Run("xcopy """ & RepSource & "\*.jpg"" """ & RepCible & """ /-Y", 1, True)
        End If
        ' S'il y a des vidps dans le rpertoire source, on les transfert
        If Tab_Mov(j) > 0 Then
            Deplace = WShell.Run("xcopy """ & RepSource & "\*.mov"" """ & RepCible & """ /-Y", 1, True)
        End If
        
        Set RepSource = Nothing
    Next

    ' Suppression ou non des fichiers prsents dans le rpertoire source
    Select Case MsgBox("Voulez-vous supprimer de la carte, les fichiers transfers ?", vbQuestion + vbYesNo, "Supprimer les fichiers ?")
    ' Si Oui, on continue, sinon ==> on sort
    Case vbNo
		Exit Sub
        'GoTo Fin
    End Select

    Existe_mais_Diff = 0
    Pas_Trouve = 0
    Existe_mais_Diff_Name = vbNewLine
    Pas_Trouve_Name = vbNewLine
    Erreur_Rep = 0
    
    ' Pour chaque fichier du rpertoire source, on s'assure qu'un fichier avec le mme Nom,
    ' la mme Date de Modification et la mme Taille est prsent dans le rpertoire cible "dat".
    For j = 0 To i - 1
        RepSourcePath = Tab_Rep(j)
        Set RepSource = Fso.GetFolder(RepSourcePath & "\")
        For Each File In RepSource.Files
            If LCase(Right(File.Name, 4)) = ".jpg" Or LCase(Right(File.Name, 4)) = ".mov" Then
                Fic_Cible = RepCible.Path & "\" & File.Name
                If Fso.FileExists(Fic_Cible) Then
                    Set Fic_Cible = Fso.GetFile(Fic_Cible)
                    If File.DateLastModified = Fic_Cible.DateLastModified And File.Size = Fic_Cible.Size Then
                        File.Delete
                    Else
                        Existe_mais_Diff = Existe_mais_Diff + 1
                        Existe_mais_Diff_Name = Existe_mais_Diff_Name & " - " & File.Name & vbNewLine
                        ' On ouvre le rpertoire des fichiers non supprims
                        If Erreur_Rep = 0 Then
                            WShell.Run "explorer " & RepSource
                            Erreur_Rep = 1
                        End If
                    End If
                Else
                    Pas_Trouve = Pas_Trouve + 1
                    Pas_Trouve_Name = Pas_Trouve_Name & " - " & File.Name & vbNewLine
                    ' On ouvre le rpertoire des fichiers non supprims
                    If Erreur_Rep = 0 Then
                        WShell.Run "explorer " & RepSource
                        Erreur_Rep = 1
                    End If
                End If
            End If
        Next
        Erreur_Rep = 0
    Next

    ' Message en cas d'erreur si fichiers diifrents
    If Existe_mais_Diff <> 0 Then
        Message = "Il y a " & Existe_mais_Diff & " fichier(s) diffrent(s) entre le fichier source et le fichier cible !" & vbNewLine & Existe_mais_Diff_Name & vbNewLine
    End If

    ' Message en cas d'erreur si fichier non prsent dans le rpertoire cible "dat" (Bore MSDOS de transfert cass, rpertoire cible plein ...)
    If Pas_Trouve <> 0 Then
        Message = Message & "Il y a " & Pas_Trouve & " fichier(s) non trouv(s) dans le rpertoire de destination !" & vbNewLine & Pas_Trouve_Name & vbNewLine
    End If

    ' Si erreur sur le delete, on affiche le message d'erreur, sinon de fin
    If Existe_mais_Diff <> 0 Or Pas_Trouve <> 0 Then
        MsgBox Message & vbNewLine & "Voici le(s) rpertoire(s) source(s) avec le(s) fichier(s) ayant pos probleme !", vbCritical, "Erreur"
    Else
        MsgBox "Fin des transferts !", vbInformation, "Fin des transferts !"
    End If

Fin:
    ' On ouvre le rpertoire cible dat
    WShell.Run "explorer " & RepCible

    ' On libre les variables
    Set Fso = Nothing
    Set WShell = Nothing
    Set Folder = Nothing
    Set RepSource = Nothing
    Set RepCible = Nothing
    Set RepSourcePath = Nothing
    Set RepCiblePath = Nothing
    Set Volume = Nothing
    Set Deplace = Nothing
    Set Message = Nothing
    Set Existe_mais_Diff = Nothing
    Set Pas_Trouve = Nothing
    Set Existe_mais_Diff_Name = Nothing
    Set Pas_Trouve_Name = Nothing
    Set File = Nothing
    Set Fic_Cible = Nothing
    Set nbFic = Nothing
    Set i = Nothing
    Set j = Nothing
    Set trouve = Nothing
    Set Erreur_Rep = Nothing

End Sub
