Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

  1. #1
    Membre à l'essai
    Profil pro
    Inscrit en
    février 2011
    Messages
    19
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : février 2011
    Messages : 19
    Points : 13
    Points
    13

    Par défaut Déplacement fichiers multimédias et créations de raccourcis

    Bonjour,
    J'ai besoin de faire un script qui déplace les fichiers multimédias (images, sons et vidéos) depuis un plan de classement situé sur un serveur vers un plan de classement miroir, sur lequel ne se trouveront que les fichiers multimédias.
    L'arborescence sera identique pour tous les répertoires contenant des fichiers multimédias.
    Il faudrait qu'en plus, il crée des raccourcis lors du déplacement des fichiers multimédias vers le nouveau plan de classement, afin qu'on puisse ouvrir ces fichiers sans galérer.
    J'ai récupéré un script qui réalise une partie du travail.
    - Déplacement des fichiers multimédias depuis le répertoire source vers le répertoire destination -> OK
    - Par contre, concernant les sous-rép. le script déplace tous les fichiers et pas seulement les fichiers images...

    Pour l'instant je n'ai sélectionné que les .tif et .png, mais il faudra ajouter quelques dizaines d'extensions supplémentaires.
    Je mets le script ci-dessous.
    Merci d'avance pour l'aide que vous pourrez m'apporter.
    Dan

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    Set objShell = CreateObject("WScript.Shell")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objNetwork = CreateObject("WScript.Network")
     
    strDestination = "D:\temp\Test\2-Arrivee\"
    strLogFile = "D:\temp\Test\2-Arrivee\CopyLog.txt"
     
    If Right(strDestination, 1) <> "\" Then strDestination = strDestination & "\"
    strSource = "D:\temp\Test\1-Depart\"
     
    Set objLogFile = objFSO.CreateTextFile(strLogFile, True)
    objLogFile.WriteLine "Script started: " & Now
    objLogFile.WriteLine "Copying files from: " & strSource & " to " & strDestination & VbCrLf
     
    For Each objFile In objFSO.GetFolder(strSource).Files
    '	If Right(LCase(objFile.Name), 4) <> ".lnk" And Right(LCase(objFile.Name), 4) <> ".url" Then
    	If Right(LCase(objFile.Name), 4) = ".tif" Or Right(LCase(objFile.Name), 4) = ".png" And Right(LCase(objFile.Name), 4) <> ".url" Then	
    		If objFSO.FileExists(strDestination & objFile.Name) = True Then
    			objLogFile.WriteLine objFile.Name & " already exists. Not copying file."
    		Else
    			strBaseName = Left(objFile.Path, InStrRev(objFile.Path, ".") - 1)
    			On Error Resume Next
    			objFSO.MoveFile objFile.Path, strDestination
    			If Err.Number = 0 Then
    				objLogFile.WriteLine "Copied file " & objFile.Name
    				CreateShortcut strBaseName & ".lnk", strDestination
    				objLogFile.WriteLine "Shortcut created: " & strBaseName & ".lnk"
    			Else
    				objLogFile.WriteLine "Error copying file " & objFile.Name & ". Error " & Err.Number & ": " & Err.Description
    			End If
    			Err.Clear
    			On Error GoTo 0
    		End If
    	End If
    Next
     
    objLogFile.WriteLine VbCrLf & "Copying folders from: " & strSource & " to " & strDestination & VbCrLf
    For Each objFolder In objFSO.GetFolder(strSource).SubFolders
    	If objFSO.FolderExists(strDestination & objFolder.Name) = True Then
    		objLogFile.WriteLine objFolder.Name & " already exists. Not copying folder."
    	Else
    		On Error Resume Next
    		objFSO.MoveFolder objFolder.Path, strDestination
    		If Err.Number = 0 Then
    			objLogFile.WriteLine "Copied folder " & objFolder.Name
    		Else
    			objLogFile.WriteLine "Error copying folder " & objFolder.Name & ". Error " & Err.Number & ": " & Err.Description
    		End If
    		Err.Clear
    		On Error GoTo 0
    	End If
    Next
     
    MsgBox "Done"
     
    Sub CreateShortcut(strName, strTarget)
    	Set objShell = CreateObject("WScript.Shell")
    	Set objLink = objShell.CreateShortcut(strName)
    	objLink.TargetPath = strTarget
    	objLink.Save
    End Sub

  2. #2
    Modérateur
    Avatar de l_autodidacte
    Homme Profil pro
    Retraité : Directeur de lycée/Professeur de sciences physiques
    Inscrit en
    juillet 2009
    Messages
    2 109
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 63
    Localisation : Tunisie

    Informations professionnelles :
    Activité : Retraité : Directeur de lycée/Professeur de sciences physiques
    Secteur : Enseignement

    Informations forums :
    Inscription : juillet 2009
    Messages : 2 109
    Points : 4 888
    Points
    4 888

    Par défaut

    Pour éviter les répétitions, tu peux définir un tableau pour les extensions à traiter puis une fonction booléenne qui vérifie si un fichier possède l'extension voulue.
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    Dim arrExtension
    arrExtension = Array("tif", "jpg", "bmp", "png", .....)
    ' La fonction
    Function VerifExtension(sFileName)
      Dim I
      For i = 0 To Ubound(arrExtension)
         If objfso.GetExtensionName(LCase(sFileName)) = arrExtension(i) Then
            VerifExtension = True
            Exit For
         End If
     Next
    End Function
    et l'appel de la fonction se fait ainsi
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    For Each objFile In objFSO.GetFolder(strSource).Files
         If VerifExtension(objFile.Path) Then
              ' ... ton traitement ici
    Ne pas oublier le tag si satisfait.
    Voter pour toute réponse satisfaisante avec pour encourager les intervenants.
    Balises CODE indispensables. Regardez ICI
    Toujours utiliser la clause Option Explicit(VBx, VBS ou VBA)
    Vous pouvez consulter mes contributions
    Consultez les différentes FAQs et les Cours/Tutoriels VB6/VBScript
    Ne pas oublier L'Aide VBScript et MSDN VB6 Fr ICI

  3. #3
    Membre à l'essai
    Profil pro
    Inscrit en
    février 2011
    Messages
    19
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : février 2011
    Messages : 19
    Points : 13
    Points
    13

    Par défaut

    Bonjour et merci pour l'aide apportée.
    C'est effectivement une bonne idée qui permet de traiter tous les types de fichiers images... sans alourdir la procédure.
    Il faudrait que le script traite les sous-répertoires comme le répertoire initial, c'est à dire déplacer uniquement les fichiers multimédias.
    Merci d'avance pour votre aide et conseils
    Dan

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    Dim arrExtension
    arrExtension = Array("tif", "jpg", "bmp", "png")
    Set objShell = CreateObject("WScript.Shell")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objNetwork = CreateObject("WScript.Network")
     
    strDestination = "D:\temp\Test\2-Arrivee\"
    strLogFile = "D:\temp\Test\2-Arrivee\CopyLog.txt"
     
    If Right(strDestination, 1) <> "\" Then strDestination = strDestination & "\"
    strSource = "D:\temp\Test\1-Depart\"
     
    Set objLogFile = objFSO.CreateTextFile(strLogFile, True)
    objLogFile.WriteLine "Script started: " & Now
    objLogFile.WriteLine "Copying files from: " & strSource & " to " & strDestination & VbCrLf
     
    For Each objFile In objFSO.GetFolder(strSource).Files
        If VerifExtension(objFile.Path) Then
    '	If Right(LCase(objFile.Name), 4) <> ".lnk" And Right(LCase(objFile.Name), 4) <> ".url" Then
    	If Right(LCase(objFile.Name), 4) = ".tif" Or Right(LCase(objFile.Name), 4) = ".png" And Right(LCase(objFile.Name), 4) <> ".url" Then	
    		If objFSO.FileExists(strDestination & objFile.Name) = True Then
    			objLogFile.WriteLine objFile.Name & " already exists. Not copying file."
    		Else
    			strBaseName = Left(objFile.Path, InStrRev(objFile.Path, ".") - 1)
    			On Error Resume Next
    			objFSO.MoveFile objFile.Path, strDestination
    			If Err.Number = 0 Then
    				objLogFile.WriteLine "Copied file " & objFile.Name
    				CreateShortcut strBaseName & ".lnk", strDestination
    				objLogFile.WriteLine "Shortcut created: " & strBaseName & ".lnk"
    			Else
    				objLogFile.WriteLine "Error copying file " & objFile.Name & ". Error " & Err.Number & ": " & Err.Description
    			End If
    			Err.Clear
    			On Error GoTo 0
    		End If
    	End If
    	End If
    Next
     
    objLogFile.WriteLine VbCrLf & "Copying folders from: " & strSource & " to " & strDestination & VbCrLf
    For Each objFolder In objFSO.GetFolder(strSource).SubFolders
    	If objFSO.FolderExists(strDestination & objFolder.Name) = True Then
    		objLogFile.WriteLine objFolder.Name & " already exists. Not copying folder."
    	Else
    		On Error Resume Next
    		objFSO.MoveFolder objFolder.Path, strDestination
    		If Err.Number = 0 Then
    			objLogFile.WriteLine "Copied folder " & objFolder.Name
    		Else
    			objLogFile.WriteLine "Error copying folder " & objFolder.Name & ". Error " & Err.Number & ": " & Err.Description
    		End If
    		Err.Clear
    		On Error GoTo 0
    	End If
    Next
     
    MsgBox "Done"
     
    Sub CreateShortcut(strName, strTarget)
    	Set objShell = CreateObject("WScript.Shell")
    	Set objLink = objShell.CreateShortcut(strName)
    	objLink.TargetPath = strTarget
    	objLink.Save
    End Sub          
     
    Function VerifExtension(sFileName)
      Dim I
      For i = 0 To Ubound(arrExtension)
         If objfso.GetExtensionName(LCase(sFileName)) = arrExtension(i) Then
            VerifExtension = True
            Exit For
         End If
     Next
    End Function

  4. #4
    Modérateur
    Avatar de l_autodidacte
    Homme Profil pro
    Retraité : Directeur de lycée/Professeur de sciences physiques
    Inscrit en
    juillet 2009
    Messages
    2 109
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 63
    Localisation : Tunisie

    Informations professionnelles :
    Activité : Retraité : Directeur de lycée/Professeur de sciences physiques
    Secteur : Enseignement

    Informations forums :
    Inscription : juillet 2009
    Messages : 2 109
    Points : 4 888
    Points
    4 888

    Par défaut

    J'ai des questions sur le déplacement:
    1. Que fait-on pour les fichiers qui ne sont pas du type multimédia ?
    2. Que fait-on pour les fichiers qui ne seront pas déplacés ?
    3. Idem pour les sous-dossiers ?


    La réponse à ces questions peut aider à concevoir le script voulu.
    Ne pas oublier le tag si satisfait.
    Voter pour toute réponse satisfaisante avec pour encourager les intervenants.
    Balises CODE indispensables. Regardez ICI
    Toujours utiliser la clause Option Explicit(VBx, VBS ou VBA)
    Vous pouvez consulter mes contributions
    Consultez les différentes FAQs et les Cours/Tutoriels VB6/VBScript
    Ne pas oublier L'Aide VBScript et MSDN VB6 Fr ICI

  5. #5
    Membre à l'essai
    Profil pro
    Inscrit en
    février 2011
    Messages
    19
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : février 2011
    Messages : 19
    Points : 13
    Points
    13

    Par défaut

    Citation Envoyé par l_autodidacte Voir le message
    J'ai des questions sur le déplacement:

    Pour expliquer un peu le pourquoi du script :
    On cherche à gagner de la place sur les serveurs de fichiers en déplaçant les fichiers mulitmédias qui représentent de gros volumes sur un NAS.
    Pour que la recherche soit facilitée, je voudrais placer des raccourcis dans le plan de classement original et pointant sur les nouveaux emplacements des fichiers déplacés.

    1. Que fait-on pour les fichiers qui ne sont pas du type multimédia ?
      Tous les fichiers qui ne sont pas multimédias, restent en place
    2. Que fait-on pour les fichiers qui ne seront pas déplacés ?
      Ils restent au même emplacement
    3. Idem pour les sous-dossiers ?
      Les sous-dossiers restent aussi au mêmes emplacements s'ils ne sont pas vides après le déplacement des fichiers multimédias.


    La réponse à ces questions peut aider à concevoir le script voulu.

  6. #6
    Modérateur
    Avatar de l_autodidacte
    Homme Profil pro
    Retraité : Directeur de lycée/Professeur de sciences physiques
    Inscrit en
    juillet 2009
    Messages
    2 109
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 63
    Localisation : Tunisie

    Informations professionnelles :
    Activité : Retraité : Directeur de lycée/Professeur de sciences physiques
    Secteur : Enseignement

    Informations forums :
    Inscription : juillet 2009
    Messages : 2 109
    Points : 4 888
    Points
    4 888

    Par défaut

    Avant de tester le code, fais une copie du dossier à traiter :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    Option Explicit' Déclaration obligatoire des variables
    Dim arrExtension, objShell, objFSO, objNetwork, strDestination, strLogFile, strSource, objLogFile, objFile, strBaseName, NewFolder, objFolder
     
    arrExtension = Array("tif", "jpg", "bmp", "png")
     
    Set objShell = CreateObject("WScript.Shell")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objNetwork = CreateObject("WScript.Network")
     
    strDestination = "D:\temp\Test\2-Arrivee\"
    strLogFile = "D:\temp\Test\2-Arrivee\CopyLog.txt"
     
    If Right(strDestination, 1) <> "\" Then strDestination = strDestination & "\"
    strSource = "D:\temp\Test\1-Depart\"
     
    Set objLogFile = objFSO.CreateTextFile(strLogFile, True)
    objLogFile.WriteLine "Script started: " & Now
     
    RecurseFolders strSource, strDestination
     
    objLogFile.Close
    MsgBox "Done"
    '====================================
    Private Sub RecurseFolders(srcFolder, DestFolder)
        Dim NomFichier, CheminFichier
        If objFSO.GetFolder(srcFolder).Files.Count = 0  Then 
             objLogFile.WriteLine "No file to copy from : " & srcFolder  & VbCrLf
        Else     
             objLogFile.WriteLine "Copying files from: " & srcFolder & " to " & DestFolder & VbCrLf
        End If
        For Each objFile In objFSO.GetFolder(srcFolder).Files
            If VerifExtension(objFile.Path) Then
                If objFSO.FileExists(DestFolder & "\" & objFile.Name) Then
                    objLogFile.WriteLine objFile.Name & " already exists. Not copying file."
                Else
                    'strBaseName = Left(objFile.Path, InStrRev(objFile.Path, ".") - 1)
                    strBaseName = objFSO.GetBaseName(objFile.Path)
                    'On Error Resume Next ' Toujours utiliser avec précaution car cela cache les erreurs
                    NomFichier = objFile.Name
                    CheminFichier = objFile.Path
                    objFSO.MoveFile objFile.Path, DestFolder & "\"
                    If Err.Number = 0 Then
                        objLogFile.WriteLine "Copied file " & NomFichier
                        ' Création des raccourcis dans le dossier principal(à vérifier selon ce dont tu as besoin)
                        CreateShortcut strDestination & "\" & strBaseName & ".lnk", CheminFichier
                        objLogFile.WriteLine "Shortcut created: " & strBaseName & ".lnk"
                    Else
                        objLogFile.WriteLine "#### Error copying file " & NomFichier & ". Error " & Err.Number & ": " & Err.Description
                    End If
                    Err.Clear
                    On Error GoTo 0
                End If
            End If
        Next
    ' On utilise la récursivité pour traiter tous les sous-dossiers    
        For Each objFolder In objFSO.GetFolder(srcFolder).SubFolders
            If  objFSO.FolderExists(DestFolder & "\" & objFolder.Name)  Then
                objLogFile.WriteLine objFolder.Name & " already exists. Not copying folder."
            Else
                Set NewFolder = objFSO.CreateFolder(DestFolder & "\" & objFolder.Name)
                Call RecurseFolders(objFolder.Path, NewFolder.Path)
            End If
        Next
    End Sub
    '==================================
    Sub CreateShortcut(strName, strTarget)
        Dim objShell, objLink
        Set objShell = CreateObject("WScript.Shell")
        Set objLink = objShell.CreateShortcut(strName)
        objLink.TargetPath = strTarget
        objLink.WorkingDirectory = Left(strName, InStrRev(strName, "\")-1)
        objLink.Save
    End Sub          
    '==================================
    Function VerifExtension(sFileName)
      Dim I
      For i = 0 To Ubound(arrExtension)
         If objfso.GetExtensionName(LCase(sFileName)) = arrExtension(i) Then
            VerifExtension = True
            Exit For
         End If
     Next
    End Function
    Ne pas oublier le tag si satisfait.
    Voter pour toute réponse satisfaisante avec pour encourager les intervenants.
    Balises CODE indispensables. Regardez ICI
    Toujours utiliser la clause Option Explicit(VBx, VBS ou VBA)
    Vous pouvez consulter mes contributions
    Consultez les différentes FAQs et les Cours/Tutoriels VB6/VBScript
    Ne pas oublier L'Aide VBScript et MSDN VB6 Fr ICI

  7. #7
    Membre à l'essai
    Profil pro
    Inscrit en
    février 2011
    Messages
    19
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : février 2011
    Messages : 19
    Points : 13
    Points
    13

    Par défaut

    Bonjour et merci pour ce joli travail !
    Il reste 2 points qui ne fonctionnent pas comme il faudrait :
    1- les raccourcis doivent figurer dans le plan de classement initial, afin qu'en cliquant sur ceux-ci, l'ouverture du fichier multimédia s'effectue depuis le NAS
    2- pour l'instant, les raccourcis ne sont créés que dans les 2 répertoires initiaux et pas dans les sous-répertoires (les fichiers multimédias, eux sont bien déplacés)

    Un autre problème qui me paraît plus bizarre : certaines fois des fichiers ne sont pas transférés dans certains sous-répertoires, sans que la structure ait été modifiée et en conservant les mêmes fichiers.
    Parfois il en reste 1 ou plusieurs, parfois tous ???

    Merci encore pour l'aide fournie et le temps passé.
    Bien cordialement
    Daniel

  8. #8
    Modérateur
    Avatar de l_autodidacte
    Homme Profil pro
    Retraité : Directeur de lycée/Professeur de sciences physiques
    Inscrit en
    juillet 2009
    Messages
    2 109
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 63
    Localisation : Tunisie

    Informations professionnelles :
    Activité : Retraité : Directeur de lycée/Professeur de sciences physiques
    Secteur : Enseignement

    Informations forums :
    Inscription : juillet 2009
    Messages : 2 109
    Points : 4 888
    Points
    4 888

    Par défaut

    1. Que veux-tu dire par Plan de classement initial ?
    2. Les raccourcis doivent pointer vers quels fichiers(ceux copiés je suppose) et où doivent-il être placés ?
    3. As-tu vérifié les attributs des fichiers non déplacés ? car si ReadOnly, il faut désactiver cet attribut.
    Ne pas oublier le tag si satisfait.
    Voter pour toute réponse satisfaisante avec pour encourager les intervenants.
    Balises CODE indispensables. Regardez ICI
    Toujours utiliser la clause Option Explicit(VBx, VBS ou VBA)
    Vous pouvez consulter mes contributions
    Consultez les différentes FAQs et les Cours/Tutoriels VB6/VBScript
    Ne pas oublier L'Aide VBScript et MSDN VB6 Fr ICI

  9. #9
    Membre à l'essai
    Profil pro
    Inscrit en
    février 2011
    Messages
    19
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : février 2011
    Messages : 19
    Points : 13
    Points
    13

    Par défaut

    Citation Envoyé par l_autodidacte Voir le message
    1. Que veux-tu dire par Plan de classement initial ?
      L'emplacement de départ des fichiers (là où ils se situent avant déplacement)
    2. Les raccourcis doivent pointer vers quels fichiers(ceux copiés je suppose) et où doivent-il être placés ?
      Les raccourcis doivent se situer à l'emplacement où se trouvaient les fichiers avant le déplacement. De cette manière en double-cliquant sur un raccourci on ouvre le fichier multimédia situé sur le NAS sans même sans que l'utilisateur s'en rende compte.
    3. As-tu vérifié les attributs des fichiers non déplacés ? car si ReadOnly, il faut désactiver cet attribut.
      Je jetterai un œil demain (au taf), mais une fois ça fonctionnait et une autre fois non, puis de nouveau OK... Pas logique.

  10. #10
    Modérateur
    Avatar de l_autodidacte
    Homme Profil pro
    Retraité : Directeur de lycée/Professeur de sciences physiques
    Inscrit en
    juillet 2009
    Messages
    2 109
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 63
    Localisation : Tunisie

    Informations professionnelles :
    Activité : Retraité : Directeur de lycée/Professeur de sciences physiques
    Secteur : Enseignement

    Informations forums :
    Inscription : juillet 2009
    Messages : 2 109
    Points : 4 888
    Points
    4 888

    Par défaut

    Essaie avec les modifications apportées au script :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    Option Explicit' Déclaration obligatoire des variables
    Dim arrExtension, objShell, objFSO, objNetwork, strDestination, strLogFile, strSource, objLogFile, objFile, strBaseName, NewFolder, objFolder
     
    arrExtension = Array("tif", "jpg", "bmp", "png")
     
    Set objShell = CreateObject("WScript.Shell")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objNetwork = CreateObject("WScript.Network")
     
    strDestination = "D:\temp\Test\2-Arrivee\"
    strLogFile = "D:\temp\Test\2-Arrivee\CopyLog.txt"
     
    If Right(strDestination, 1) <> "\" Then strDestination = strDestination & "\"
    strSource = "D:\temp\Test\1-Depart\"
    ' Efface les attributs R, S et H
    objShell.Run "Cmd.exe /C Attrib " & strSource & "*.* -r -s -h /S" , 0 , False ' ##Modification ici
     
     
    Set objLogFile = objFSO.CreateTextFile(strLogFile, True)
    objLogFile.WriteLine "Script started: " & Now
     
    RecurseFolders strSource, strDestination
     
    objLogFile.Close
    MsgBox "Done"
    '====================================
    Private Sub RecurseFolders(srcFolder, DestFolder)
        Dim NomFichier , CheminFichier
        If objFSO.GetFolder(srcFolder).Files.Count = 0  Then 
             objLogFile.WriteLine "No file to copy from : " & srcFolder  & VbCrLf
        Else     
             objLogFile.WriteLine "Copying files from: " & srcFolder & " to " & DestFolder & VbCrLf
        End If
        For Each objFile In objFSO.GetFolder(srcFolder).Files
            If VerifExtension(objFile.Path) Then
                If objFSO.FileExists(DestFolder & "\" & objFile.Name) Then
                    objLogFile.WriteLine objFile.Name & " already exists. Not copying file."
                Else
                    'strBaseName = Left(objFile.Path, InStrRev(objFile.Path, ".") - 1)
                    strBaseName = objFSO.GetBaseName(objFile.Path)
                    'On Error Resume Next ' Toujours utiliser avec précaution car cela cache des erreurs éventuelles
                    NomFichier = objFile.Name
                    CheminFichier = objFSO.GetFile(objFile.Path).ParentFolder  ' ##Modification ici
                    objFSO.MoveFile objFile.Path, DestFolder & "\"
                    If Err.Number = 0 Then
                        objLogFile.WriteLine "Copied file " & NomFichier
                        ' Création des raccourcis dans le dossier origine des fichiers
                        CreateShortcut CheminFichier & "\" & strBaseName & ".lnk", DestFolder & "\" & NomFichier ' ##Modification ici
                        objLogFile.WriteLine "Shortcut created: " & strBaseName & ".lnk"
                    Else
                        objLogFile.WriteLine "#### Error copying file " & NomFichier & ". Error " & Err.Number & ": " & Err.Description
                    End If
                    Err.Clear
                    On Error GoTo 0
                End If
            End If
        Next
     
        ' On utilise la récursivité pour traiter tous les sous-dossiers    
     
        For Each objFolder In objFSO.GetFolder(srcFolder).SubFolders
            If  objFSO.FolderExists(DestFolder & "\" & objFolder.Name)  Then
                '### Suite à cette condition, si le dossier cible existe, les fichiers ne seront pas déplacés
                '### Ils resteront dans le dossier source
                objLogFile.WriteLine objFolder.Name & " already exists. Not copying folder."
            Else
                Set NewFolder = objFSO.CreateFolder(DestFolder & "\" & objFolder.Name)
                Call RecurseFolders(objFolder.Path, NewFolder.Path)
            End If
        Next
    End Sub
    '==================================
    Sub CreateShortcut(strName, strTarget)
        Dim objShell, objLink
        Set objShell = CreateObject("WScript.Shell")
        Set objLink = objShell.CreateShortcut(strName)
        objLink.TargetPath = strTarget
        objLink.WorkingDirectory = Left(strName, InStrRev(strName, "\")-1)
        objLink.Save
    End Sub          
    '==================================
    Function VerifExtension(sFileName)
      Dim I
      For i = 0 To Ubound(arrExtension)
         If objfso.GetExtensionName(LCase(sFileName)) = arrExtension(i) Then
            VerifExtension = True
            Exit For
         End If
     Next
    End Function
    Ne pas oublier le tag si satisfait.
    Voter pour toute réponse satisfaisante avec pour encourager les intervenants.
    Balises CODE indispensables. Regardez ICI
    Toujours utiliser la clause Option Explicit(VBx, VBS ou VBA)
    Vous pouvez consulter mes contributions
    Consultez les différentes FAQs et les Cours/Tutoriels VB6/VBScript
    Ne pas oublier L'Aide VBScript et MSDN VB6 Fr ICI

  11. #11
    Membre à l'essai
    Profil pro
    Inscrit en
    février 2011
    Messages
    19
    Détails du profil
    Informations personnelles :
    Localisation : France

    Informations forums :
    Inscription : février 2011
    Messages : 19
    Points : 13
    Points
    13

    Par défaut Tip - Top !

    Bravo et merci beaucoup !
    Ça fonctionne impeccablement bien.
    Juste un point qui coince, mais avec lequel je ferai s'il n'y a pas de solution simple :
    lorsque le nom d'un fichier comporte un caractère accentué (il ne devrait pas y en avoir, mais bon...), l'accent du raccourci se retrouve entre 2 caractères. Le raccourci ne fonctionne donc pas.

    Pour exemple :
    Fichier origine : Râle des genets_Bronner_Small.jpg
    Raccourci : Ra^le des genets_Bronner_Small.lnk

    Ça risque d'être plus impactant si on a des répertoires comportant des accents, car pour tous les fichiers de ce répertoire et de ses sous-répertoires, les raccourcis ne fonctionneront pas.
    Est-ce que ça pourrait être un problème d'encodage ?

    En tout cas, si ça ne te dit rien, merci beaucoup pour toute l'aide apportée et le temps passé.
    Dan

  12. #12
    Rédacteur/Modérateur
    Avatar de ProgElecT
    Homme Profil pro
    Retraité
    Inscrit en
    décembre 2004
    Messages
    4 628
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 62
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Retraité
    Secteur : Communication - Médias

    Informations forums :
    Inscription : décembre 2004
    Messages : 4 628
    Points : 10 190
    Points
    10 190

    Par défaut

    Salut
    Citation Envoyé par Dan25 Voir le message
    Bravo et merci beaucoup !......... pour toute l'aide apportée et le temps passé.
    Dan
    tu peux remercier aussi en mettant des à celui qui te donne le coup de main.
    ProgElecT
    Soyez sympa, pensez -y
    Balises[CODE]...[/CODE]
    Balises[CODE=NomDuLangage]...[/CODE] quand vous mettez du code d'un autre langage que celui du forum ou vous postez.
    Le bouton en fin de discussion, quand vous avez obtenu l'aide attendue.
    ......... et pourquoi pas, pour remercier, un pour celui/ceux qui vous ont dépannés.

  13. #13
    Modérateur
    Avatar de l_autodidacte
    Homme Profil pro
    Retraité : Directeur de lycée/Professeur de sciences physiques
    Inscrit en
    juillet 2009
    Messages
    2 109
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 63
    Localisation : Tunisie

    Informations professionnelles :
    Activité : Retraité : Directeur de lycée/Professeur de sciences physiques
    Secteur : Enseignement

    Informations forums :
    Inscription : juillet 2009
    Messages : 2 109
    Points : 4 888
    Points
    4 888

    Par défaut

    Pour se débarrasser des accents :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    Option Explicit 
    Dim arrAcc, arrChar
     ' A titre d'exemple. il faut voir les autres cas(caractères majuscules)
     arrAcc  = Array("â", "à", "ä", "é", "ê", "è", "ë", "î", "ï", "ô", "ö", "û", "ü", "ù") 
     arrChar = Array("a", "a", "a", "e", "e", "e", "e", "i", "i", "o", "o", "u", "u", "u")
    Function SansAccent(strIn)
       Dim I, Ret
       Ret = strIn
       For I = 0 To Ubound(arrAcc)
          Ret = Replace(Ret, arrAcc(I), arrChar(I))
       Next 
       SansAccent = Ret
    End Function
    ' Exemple :
    MsgBox SansAccent("Brûte et bête ambiguës")
    De ce fait, remplace la ligne 48(pour les raccourcis) par :
    CreateShortcut CheminFichier & "\" & SansAccent(strBaseName) & ".lnk", DestFolder & "\" & NomFichier
    Ne pas oublier le tag si satisfait.
    Voter pour toute réponse satisfaisante avec pour encourager les intervenants.
    Balises CODE indispensables. Regardez ICI
    Toujours utiliser la clause Option Explicit(VBx, VBS ou VBA)
    Vous pouvez consulter mes contributions
    Consultez les différentes FAQs et les Cours/Tutoriels VB6/VBScript
    Ne pas oublier L'Aide VBScript et MSDN VB6 Fr ICI

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. Les freewares pour la lecture de fichiers multimédias
    Par Michaël dans le forum Autres Logiciels
    Réponses: 41
    Dernier message: 03/08/2017, 08h43
  2. Création de raccourci de fichier dans le code
    Par solofohery dans le forum Discussions diverses
    Réponses: 1
    Dernier message: 28/09/2012, 19h02
  3. création répertoire et déplacement fichier
    Par chercheur111 dans le forum MATLAB
    Réponses: 8
    Dernier message: 30/04/2011, 23h20
  4. Création de raccourci clavier
    Par Atomikx dans le forum MFC
    Réponses: 2
    Dernier message: 13/11/2005, 19h28
  5. Création de raccourcis - c
    Par Age Piranha dans le forum Windows
    Réponses: 3
    Dernier message: 10/04/2005, 13h43

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo