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
| Sub RenommerFichiers()
Const FormatF = "" 'Format du fichier ex : "jpg" ou "pdf"
=> si tout les fichiers à renommer ont le même format - sinon laisser à vide
Const Col_Nom = 2: Const Entete = 0: Const Decal_Col = 4
Dim VA, VB(), Dossier$, DossierAS$, DL&, i&, VBAList$, MonScript$, NomD$, Ext
'---------------------------------------------------------------------------------------------------------
' Détection si le code est utilisé sur un Mac puis détecte la version d'Excel (pour Excel 2011 - 2016)
VApp = Val(Application.Version)
#If Mac Then
If VApp >= 15 Then _
Dossier = MacScript("POSIX path of (choose folder) as Unicode text") Else _
Dossier = MacScript("(choose folder) as Unicode text"): _
DossierAS = MacScript("tell application ""Finder"" to POSIX path of " & Chr(34) & Dossier & Chr(34) & " as Unicode text")
#Else
MsgBox "Ce code est conçu pour Excel Mac 2011, 2016 et +": Exit Sub
#End If
DL = Cells(Rows.Count, Col_Nom).End(xlUp).Row
VA = Range(Cells(1 + Entete, Col_Nom), Cells(DL, Col_Nom + 1)).Value
NomType = MsgBox("Les noms des photos sont-ils du type ""0001"" ?", vbYesNo, "Noms type des photos sur le disque dur")
If NomType = vbYes Then
For i = LBound(VA) To UBound(VA) ' Boucle à utiliser si le nom du fichier dans les disque dur est du type "0000" (comme "0015") alors que dans Excel le nom est du type "0" (comme "15")
If InStr(VA(i, 1), ".") > 0 Then
VA(i, 1) = Format(Left(VA(i, 1), InStr(VA(i, 1), ".") - 1), "0000")
Else
VA(i, 1) = Format(VA(i, 1), "0000")
End If
Next
End If
ReDim VB(1 To UBound(VA), 1 To 1)
If FormatF = "" Then
'---------------------------------------------------------------------------------------------------------
' Partie de code lorsque le format du fichier n'est pas connu à l'avance , dans ce cas le script s'occupe de récupérer les bonnes extensions
' Attention toutefois dans cette version, si il y a plusieurs noms identiques mais avec des extensions différentes, le code prendra la 1ère extension trouvé
' Renommage des noms
VBAList = """" & Join(Application.Transpose(Application.Index(VA, 0, 1)), """, """) & """"
MonScript = "set pFolder to " & Chr(34) & IIf(VApp > 15, Dossier, DossierAS) & Chr(34) & Chr(13) & "set myList to " & "{" & VBAList & "}"
MonScript = MonScript & Chr(13) & "set TheNewlist to {}" & Chr(13) & "repeat with theItem in myList"
MonScript = MonScript & Chr(13) & "set Chm to (do shell script ""find "" & quoted form of pFolder & "" -name "" & theItem & ""* | awk -F . '{print $2}'"") as text"
MonScript = MonScript & Chr(13) & "set end of TheNewlist to Chm" & Chr(13) & "end repeat" & Chr(13) & "set text item delimiters to return" & Chr(13) & " set TheNewlist to TheNewlist as Unicode text"
Ext = MacScript(MonScript): Ext = Split(Ext, Chr(13))
For i = LBound(Ext) To UBound(Ext): Debug.Print Ext(i): Next
For i = LBound(VA) To UBound(VA)
If InStr(VA(i, 1), ".") > 0 Then NomD = Mid(VA(i, 1), 1, InStr(VA(i, 1), ".") - 1) Else NomD = VA(i, 1)
If Ext(i - 1) > "" Then
VB(i, 1) = VA(i, 2) & "_" & Format(NomD, "0000") & "." & Ext(i - 1)
Name Dossier & NomD & "." & Ext(i - 1) As Dossier & VB(i, 1)
Else
VB(i, 1) = "Fichier non trouvé"
End If
Next
Else
'---------------------------------------------------------------------------------------------------------
' Partie de code lorsque le format du fichier est unique, dans ce cas la constante "Format" doit être renseignée - Ex : "xls" ou "jpg"
' Renommage des noms
On Error Resume Next ' =============== DEBUT GESTION D'ERREUR =================== => Obligatoire sur OS X pour la vérif avec Dir
For i = LBound(VA) To UBound(VA)
If InStr(VA(i, 1), ".") > 0 Then NomD = Mid(VA(i, 1), 1, InStr(VA(i, 1), ".") - 1) Else NomD = VA(i, 1)
If Dir(Dossier & NomD & "." & FormatF) = vbNullString Then
VB(i, 1) = "Fichier non trouvé"
Else
VB(i, 1) = VA(i, 2) & "_" & Format(NomD, "0000") & "." & FormatF
Name Dossier & NomD & "." & FormatF As Dossier & VB(i, 1)
End If
Next
On Error GoTo 0 ' =============== FIN GESTION D'ERREUR ===================
End If
'---------------------------------------------------------------------------------------------------------
' Permet de mettre les nouveaux noms en remplacement ou en décalage de la colonne des anciens noms
Cells(1 + Entete, Col_Nom + Decal_Col).Resize(UBound(VB)) = VB
MsgBox "Renommage des fichiers terminé"
End Sub |
Partager